EPUB reader: Further URI handling improvements.

Now we outsource most of the work to `fetchItem'`.
Also, do not include queries in file extensions.

Improves fix to #1671.

It is possible that this will have some unexpected effects, so
further testing would be good.
This commit is contained in:
John MacFarlane 2014-10-08 15:43:58 -07:00
parent f8087b6c43
commit 2eaa0f6ab1

View file

@ -64,8 +64,6 @@ import Text.XML.Light ( unode, Element(..), unqual, Attr(..), add_attrs
import Text.Pandoc.UUID (getRandomUUID)
import Text.Pandoc.Writers.HTML (writeHtmlString, writeHtml)
import Data.Char ( toLower, isDigit, isAlphaNum )
import Network.URI ( unEscapeString, nonStrictRelativeTo,
escapeURIString, isAllowedInURI, parseURIReference )
import Text.Pandoc.MIME (MimeType, getMimeType)
import qualified Control.Exception as E
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
@ -766,23 +764,20 @@ metadataElement version md currentTime =
showDateTimeISO8601 :: UTCTime -> String
showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ"
transformTag :: WriterOptions
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) media
transformTag :: IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) media
-> Tag String
-> IO (Tag String)
transformTag opts mediaRef tag@(TagOpen name attr)
transformTag mediaRef tag@(TagOpen name attr)
| name `elem` ["video", "source", "img", "audio"] = do
let src = fromAttrib "src" tag
let poster = fromAttrib "poster" tag
let oldsrc = src `relativeTo` writerSourceURL opts
let oldposter = poster `relativeTo` writerSourceURL opts
newsrc <- modifyMediaRef mediaRef oldsrc
newposter <- modifyMediaRef mediaRef oldposter
newsrc <- modifyMediaRef mediaRef src
newposter <- modifyMediaRef mediaRef poster
let attr' = filter (\(x,_) -> x /= "src" && x /= "poster") attr ++
[("src", newsrc) | not (null newsrc)] ++
[("poster", newposter) | not (null newposter)]
return $ TagOpen name attr'
transformTag _ _ tag = return tag
transformTag _ tag = return tag
modifyMediaRef :: IORef [(FilePath, FilePath)] -> FilePath -> IO FilePath
modifyMediaRef _ "" = return ""
@ -792,7 +787,7 @@ modifyMediaRef mediaRef oldsrc = do
Just n -> return n
Nothing -> do
let new = "media/file" ++ show (length media) ++
takeExtension oldsrc
takeExtension (takeWhile (/='?') oldsrc) -- remove query
modifyIORef mediaRef ( (oldsrc, new): )
return new
@ -800,10 +795,10 @@ transformBlock :: WriterOptions
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) media
-> Block
-> IO Block
transformBlock opts mediaRef (RawBlock fmt raw)
transformBlock _ mediaRef (RawBlock fmt raw)
| fmt == Format "html" = do
let tags = parseTags raw
tags' <- mapM (transformTag opts mediaRef) tags
tags' <- mapM (transformTag mediaRef) tags
return $ RawBlock fmt (renderTags' tags')
transformBlock _ _ b = return b
@ -811,18 +806,17 @@ transformInline :: WriterOptions
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) media
-> Inline
-> IO Inline
transformInline opts mediaRef (Image lab (src,tit)) = do
let oldsrc = src `relativeTo` writerSourceURL opts
newsrc <- modifyMediaRef mediaRef oldsrc
transformInline _ mediaRef (Image lab (src,tit)) = do
newsrc <- modifyMediaRef mediaRef src
return $ Image lab (newsrc, tit)
transformInline opts _ (x@(Math _ _))
| WebTeX _ <- writerHTMLMathMethod opts = do
raw <- makeSelfContained opts $ writeHtmlInline opts x
return $ RawInline (Format "html") raw
transformInline opts mediaRef (RawInline fmt raw)
transformInline _ mediaRef (RawInline fmt raw)
| fmt == Format "html" = do
let tags = parseTags raw
tags' <- mapM (transformTag opts mediaRef) tags
tags' <- mapM (transformTag mediaRef) tags
return $ RawInline fmt (renderTags' tags')
transformInline _ _ x = return x
@ -1205,10 +1199,3 @@ docTitle' meta = fromMaybe [] $ go <$> lookupMeta "title" meta
go (MetaList xs) = concatMap go xs
go _ = []
relativeTo :: String -> Maybe String -> String
relativeTo src mbbase =
case (parseURIReference (ensureEscaped src),
mbbase >>= parseURIReference . ensureEscaped) of
(Just src', Just base') -> show (src' `nonStrictRelativeTo` base')
_ -> unEscapeString src
where ensureEscaped = escapeURIString isAllowedInURI