EPUB writer: Incorporate files linked in <video> tags.
src and poster will both be incorporated into content.opf and the epub container. This partially address #1170. Still need to do something similar for <audio>.
This commit is contained in:
parent
814af2002e
commit
f6141aa241
2 changed files with 47 additions and 10 deletions
|
@ -246,6 +246,7 @@ mimeTypesList = -- List borrowed from happstack-server.
|
||||||
,("lzx","application/x-lzx")
|
,("lzx","application/x-lzx")
|
||||||
,("m3u","audio/mpegurl")
|
,("m3u","audio/mpegurl")
|
||||||
,("m4a","audio/mpeg")
|
,("m4a","audio/mpeg")
|
||||||
|
,("m4v","video/x-m4v")
|
||||||
,("maker","application/x-maker")
|
,("maker","application/x-maker")
|
||||||
,("man","application/x-troff-man")
|
,("man","application/x-troff-man")
|
||||||
,("mcif","chemical/x-mmcif")
|
,("mcif","chemical/x-mmcif")
|
||||||
|
|
|
@ -65,6 +65,7 @@ import Prelude hiding (catch)
|
||||||
#endif
|
#endif
|
||||||
import Control.Exception (catch, SomeException)
|
import Control.Exception (catch, SomeException)
|
||||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
||||||
|
import Text.HTML.TagSoup
|
||||||
|
|
||||||
-- A Chapter includes a list of blocks and maybe a section
|
-- A Chapter includes a list of blocks and maybe a section
|
||||||
-- number offset. Note, some chapters are unnumbered. The section
|
-- number offset. Note, some chapters are unnumbered. The section
|
||||||
|
@ -342,8 +343,8 @@ writeEPUB opts doc@(Pandoc meta _) = do
|
||||||
|
|
||||||
-- handle pictures
|
-- handle pictures
|
||||||
picsRef <- newIORef []
|
picsRef <- newIORef []
|
||||||
Pandoc _ blocks <- walkM
|
Pandoc _ blocks <- walkM (transformInline opts' picsRef) doc >>=
|
||||||
(transformInline opts' picsRef) doc
|
walkM (transformBlock opts' picsRef)
|
||||||
pics <- readIORef picsRef
|
pics <- readIORef picsRef
|
||||||
let readPicEntry entries (oldsrc, newsrc) = do
|
let readPicEntry entries (oldsrc, newsrc) = do
|
||||||
res <- fetchItem (writerSourceURL opts') oldsrc
|
res <- fetchItem (writerSourceURL opts') oldsrc
|
||||||
|
@ -715,21 +716,55 @@ metadataElement version md currentTime =
|
||||||
showDateTimeISO8601 :: UTCTime -> String
|
showDateTimeISO8601 :: UTCTime -> String
|
||||||
showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ"
|
showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ"
|
||||||
|
|
||||||
|
transformTag :: WriterOptions
|
||||||
|
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) images
|
||||||
|
-> Tag String
|
||||||
|
-> IO (Tag String)
|
||||||
|
transformTag opts picsRef tag@(TagOpen "video" attr) = do
|
||||||
|
let src = fromAttrib "src" tag
|
||||||
|
let poster = fromAttrib "poster" tag
|
||||||
|
let oldsrc = maybe src (</> src) $ writerSourceURL opts
|
||||||
|
let oldposter = maybe poster (</> poster) $ writerSourceURL opts
|
||||||
|
newsrc <- modifyPicsRef picsRef oldsrc
|
||||||
|
newposter <- modifyPicsRef picsRef oldposter
|
||||||
|
let attr' = filter (\(x,_) -> x /= "src" && x /= "poster") attr ++
|
||||||
|
[("src", newsrc) | not (null newsrc)] ++
|
||||||
|
[("poster", newposter) | not (null newposter)]
|
||||||
|
return $ TagOpen "video" attr'
|
||||||
|
transformTag _ _ tag = return tag
|
||||||
|
|
||||||
|
modifyPicsRef :: IORef [(FilePath, FilePath)] -> FilePath -> IO FilePath
|
||||||
|
modifyPicsRef _ "" = return ""
|
||||||
|
modifyPicsRef picsRef oldsrc = do
|
||||||
|
pics <- readIORef picsRef
|
||||||
|
case lookup oldsrc pics of
|
||||||
|
Just n -> return n
|
||||||
|
Nothing -> do
|
||||||
|
let new = "images/img" ++ show (length pics) ++
|
||||||
|
takeExtension oldsrc
|
||||||
|
modifyIORef picsRef ( (oldsrc, new): )
|
||||||
|
return new
|
||||||
|
|
||||||
|
transformBlock :: WriterOptions
|
||||||
|
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) images
|
||||||
|
-> Block
|
||||||
|
-> IO Block
|
||||||
|
transformBlock opts picsRef (RawBlock fmt raw)
|
||||||
|
| fmt == Format "html" = do
|
||||||
|
let tags = parseTags raw
|
||||||
|
-- look for video tags and add poster and src to images
|
||||||
|
tags' <- mapM (transformTag opts picsRef) tags
|
||||||
|
return $ RawBlock fmt (renderTags tags')
|
||||||
|
transformBlock _ _ b = return b
|
||||||
|
|
||||||
transformInline :: WriterOptions
|
transformInline :: WriterOptions
|
||||||
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) images
|
-> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) images
|
||||||
-> Inline
|
-> Inline
|
||||||
-> IO Inline
|
-> IO Inline
|
||||||
transformInline opts picsRef (Image lab (src,tit)) = do
|
transformInline opts picsRef (Image lab (src,tit)) = do
|
||||||
let src' = unEscapeString src
|
let src' = unEscapeString src
|
||||||
pics <- readIORef picsRef
|
|
||||||
let oldsrc = maybe src' (</> src) $ writerSourceURL opts
|
let oldsrc = maybe src' (</> src) $ writerSourceURL opts
|
||||||
let ext = takeExtension src'
|
newsrc <- modifyPicsRef picsRef oldsrc
|
||||||
newsrc <- case lookup oldsrc pics of
|
|
||||||
Just n -> return n
|
|
||||||
Nothing -> do
|
|
||||||
let new = "images/img" ++ show (length pics) ++ ext
|
|
||||||
modifyIORef picsRef ( (oldsrc, new): )
|
|
||||||
return new
|
|
||||||
return $ Image lab (newsrc, tit)
|
return $ Image lab (newsrc, tit)
|
||||||
transformInline opts _ (x@(Math _ _))
|
transformInline opts _ (x@(Math _ _))
|
||||||
| WebTeX _ <- writerHTMLMathMethod opts = do
|
| WebTeX _ <- writerHTMLMathMethod opts = do
|
||||||
|
@ -762,6 +797,7 @@ ppTopElement = ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++) . unEntity .
|
||||||
imageTypeOf :: FilePath -> Maybe String
|
imageTypeOf :: FilePath -> Maybe String
|
||||||
imageTypeOf x = case getMimeType x of
|
imageTypeOf x = case getMimeType x of
|
||||||
Just y@('i':'m':'a':'g':'e':_) -> Just y
|
Just y@('i':'m':'a':'g':'e':_) -> Just y
|
||||||
|
Just y@('v':'i':'d':'e':'o':_) -> Just y
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
data IdentState = IdentState{
|
data IdentState = IdentState{
|
||||||
|
|
Loading…
Add table
Reference in a new issue