@@ -0,0 +1,247 @@
1+{-
2+Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Writers.EPUB
21+ Copyright : Copyright (C) 2010 John MacFarlane
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : John MacFarlane <jgm@berkeley.edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Conversion of 'Pandoc' documents to EPUB.
29+-}
30+module Text.Pandoc.Writers.EPUB ( writeEPUB ) where
31+import Data.IORef
32+import Data.Maybe ( fromMaybe, isNothing )
33+import Data.List ( findIndices, isPrefixOf )
34+import System.Environment ( getEnv )
35+import System.FilePath ( (</>), takeBaseName, takeExtension )
36+import qualified Data.ByteString.Lazy as B
37+import Data.ByteString.Lazy.UTF8 ( fromString )
38+import Codec.Archive.Zip
39+import System.Time
40+import Text.Pandoc.Shared hiding ( Element )
41+import Text.Pandoc.Definition
42+import Control.Monad (liftM)
43+import Text.XML.Light hiding (ppTopElement)
44+import Text.Pandoc.UUID
45+import Text.Pandoc.Writers.HTML
46+import Text.Pandoc.Writers.Markdown ( writePlain )
47+import Data.Char ( toLower )
48+
49+-- | Produce an EPUB file from a Pandoc document.
50+writeEPUB :: FilePath -- ^ Relative directory of source file
51+ -> String -- ^ EPUB stylesheet
52+ -> WriterOptions -- ^ Writer options
53+ -> Pandoc -- ^ Document to convert
54+ -> IO B.ByteString
55+writeEPUB sourceDir stylesheet opts doc = do
56+ (TOD epochtime _) <- getClockTime
57+ let opts' = opts{ writerEmailObfuscation = NoObfuscation
58+ , writerStandalone = True
59+ , writerWrapText = False }
60+ -- mimetype
61+ let mimetypeEntry = toEntry "mimetype" epochtime $ fromString "application/epub+zip"
62+ -- container.xml
63+ let containerData = fromString $ ppTopElement $
64+ unode "container" ! [("version","1.0")
65+ ,("xmlns","urn:oasis:names:tc:opendocument:xmlns:container")] $
66+ unode "rootfiles" $
67+ unode "rootfile" ! [("full-path","content.opf")
68+ ,("media-type","application/oebps-package+xml")] $ ()
69+ let containerEntry = toEntry "META-INF/container.xml" epochtime containerData
70+ -- stylesheet
71+ let stylesheetEntry = toEntry "stylesheet.css" epochtime $
72+ fromString stylesheet
73+ -- title page
74+ let vars = writerVariables opts'
75+ let tpContent = fromString $
76+ writeHtmlString opts'{writerTemplate = pageTemplate
77+ ,writerVariables = ("titlepage","yes"):vars} doc
78+ let tpEntry = toEntry "title_page.xhtml" epochtime tpContent
79+ -- handle pictures
80+ picEntriesRef <- newIORef ([] :: [Entry])
81+ Pandoc meta blocks <- liftM (processWith transformBlock) $
82+ processWithM (transformInline (writerHTMLMathMethod opts)
83+ sourceDir picEntriesRef) doc
84+ picEntries <- readIORef picEntriesRef
85+ -- body pages
86+ let isH1 (Header 1 _) = True
87+ isH1 _ = False
88+ let chunks = splitByIndices (dropWhile (==0) $ findIndices isH1 blocks) blocks
89+ let titleize (Header 1 xs : ys) = Pandoc meta{docTitle = xs} ys
90+ titleize xs = Pandoc meta xs
91+ let chapToHtml = writeHtmlString opts'{ writerTemplate = pageTemplate
92+ , writerHTMLMathMethod = PlainMath}
93+ let chapters = map titleize chunks
94+ let chapterToEntry :: Int -> Pandoc -> Entry
95+ chapterToEntry num chap = toEntry ("ch" ++ show num ++ ".xhtml")
96+ epochtime $ fromString $ chapToHtml chap
97+ let chapterEntries = zipWith chapterToEntry [1..] chapters
98+ -- contents.opf
99+ uuid <- getRandomUUID
100+ let chapterNode ent = unode "item" !
101+ [("id", takeBaseName $ eRelativePath ent),
102+ ("href", eRelativePath ent),
103+ ("media-type", "application/xhtml+xml")] $ ()
104+ let chapterRefNode ent = unode "itemref" !
105+ [("idref", takeBaseName $ eRelativePath ent)] $ ()
106+ let pictureNode ent = unode "item" !
107+ [("id", takeBaseName $ eRelativePath ent),
108+ ("href", eRelativePath ent),
109+ ("media-type", fromMaybe "application/octet-stream"
110+ $ imageTypeOf $ eRelativePath ent)] $ ()
111+ let plainify t = removeTrailingSpace $
112+ writePlain opts'{ writerStandalone = False } $
113+ Pandoc meta [Plain t]
114+ let plainTitle = plainify $ docTitle meta
115+ let plainAuthors = map plainify $ docAuthors meta
116+ lang <- catch (liftM (takeWhile (/='.')) $ getEnv "lang")
117+ (\_ -> return "en-US")
118+ let contentsData = fromString $ ppTopElement $
119+ unode "package" ! [("version","2.0")
120+ ,("xmlns","http://www.idpf.org/2007/opf")
121+ ,("unique-identifier","BookId")] $
122+ [ unode "metadata" ! [("xmlns:dc","http://purl.org/dc/elements/1.1/")
123+ ,("xmlns:opf","http://www.idpf.org/2007/opf")] $
124+ [ unode "dc:title" plainTitle
125+ , unode "dc:language" lang
126+ , unode "dc:identifier" ! [("id","BookId")] $ show uuid
127+ ] ++
128+ map (unode "dc:creator" ! [("opf:role","aut")]) plainAuthors
129+ , unode "manifest" $
130+ [ unode "item" ! [("id","ncx"), ("href","toc.ncx")
131+ ,("media-type","application/x-dtbncx+xml")] $ ()
132+ , unode "item" ! [("id","style"), ("href","stylesheet.css")
133+ ,("media-type","text/css")] $ ()
134+ ] ++
135+ map chapterNode (tpEntry : chapterEntries) ++
136+ map pictureNode picEntries
137+ , unode "spine" ! [("toc","ncx")] $
138+ map chapterRefNode (tpEntry : chapterEntries)
139+ ]
140+ let contentsEntry = toEntry "content.opf" epochtime contentsData
141+ -- toc.ncx
142+ let navPointNode ent n tit = unode "navPoint" !
143+ [("id", "navPoint-" ++ show n)
144+ ,("playOrder", show n)] $
145+ [ unode "navLabel" $ unode "text" tit
146+ , unode "content" ! [("src",
147+ eRelativePath ent)] $ ()
148+ ]
149+ let tocData = fromString $ ppTopElement $
150+ unode "ncx" ! [("version","2005-1")
151+ ,("xmlns","http://www.daisy.org/z3986/2005/ncx/")] $
152+ [ unode "head"
153+ [ unode "meta" ! [("name","dtb:uid")
154+ ,("content", show uuid)] $ ()
155+ , unode "meta" ! [("name","dtb:depth")
156+ ,("content", "1")] $ ()
157+ , unode "meta" ! [("name","dtb:totalPageCount")
158+ ,("content", "0")] $ ()
159+ , unode "meta" ! [("name","dtb:maxPageNumber")
160+ ,("content", "0")] $ ()
161+ ]
162+ , unode "docTitle" $ unode "text" $ plainTitle
163+ , unode "navMap" $ zipWith3 navPointNode (tpEntry : chapterEntries)
164+ [1..(length chapterEntries + 1)]
165+ ("Title Page" : map (\(Pandoc m _) ->
166+ plainify $ docTitle m) chapters)
167+ ]
168+ let tocEntry = toEntry "toc.ncx" epochtime tocData
169+ -- construct archive
170+ let archive = foldr addEntryToArchive emptyArchive
171+ (mimetypeEntry : containerEntry : stylesheetEntry : tpEntry :
172+ contentsEntry : tocEntry : (picEntries ++ chapterEntries) )
173+ return $ fromArchive archive
174+
175+transformInline :: HTMLMathMethod
176+ -> FilePath
177+ -> IORef [Entry]
178+ -> Inline
179+ -> IO Inline
180+transformInline _ _ _ (Image lab (src,_)) | isNothing (imageTypeOf src) =
181+ return (Emph lab)
182+transformInline _ sourceDir picsRef (Image lab (src,tit)) = do
183+ entries <- readIORef picsRef
184+ let newsrc = "images/img" ++ show (length entries) ++ takeExtension src
185+ catch (readEntry [] (sourceDir </> src) >>= \entry ->
186+ modifyIORef picsRef (entry{ eRelativePath = newsrc } :) >>
187+ return (Image lab (newsrc, tit)))
188+ (\_ -> return (Emph lab))
189+transformInline (MathML _) _ _ x@(Math _ _) = do
190+ let writeHtmlInline opts z = removeTrailingSpace $
191+ writeHtmlString opts $ Pandoc (Meta [] [] []) [Plain [z]]
192+ mathml = writeHtmlInline defaultWriterOptions{
193+ writerHTMLMathMethod = MathML Nothing } x
194+ fallback = writeHtmlInline defaultWriterOptions{
195+ writerHTMLMathMethod = PlainMath } x
196+ inOps = "<ops:switch xmlns:ops=\"http://www.idpf.org/2007/ops\">" ++
197+ "<ops:case required-namespace=\"http://www.w3.org/1998/Math/MathML\">" ++
198+ mathml ++ "</ops:case><ops:default>" ++ fallback ++ "</ops:default>" ++
199+ "</ops:switch>"
200+ return $ HtmlInline $ if "<math" `isPrefixOf` mathml then inOps else mathml
201+transformInline _ _ _ (HtmlInline _) = return $ Str ""
202+transformInline _ _ _ x = return x
203+
204+transformBlock :: Block -> Block
205+transformBlock (RawHtml _) = Null
206+transformBlock x = x
207+
208+(!) :: Node t => (t -> Element) -> [(String, String)] -> t -> Element
209+(!) f attrs n = add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) (f n)
210+
211+-- | Version of 'ppTopElement' that specifies UTF-8 encoding.
212+ppTopElement :: Element -> String
213+ppTopElement = ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++) . ppElement
214+
215+imageTypeOf :: FilePath -> Maybe String
216+imageTypeOf x = case drop 1 (map toLower (takeExtension x)) of
217+ "jpg" -> Just "image/jpeg"
218+ "jpeg" -> Just "image/jpeg"
219+ "jfif" -> Just "image/jpeg"
220+ "png" -> Just "image/png"
221+ "gif" -> Just "image/gif"
222+ "svg" -> Just "image/svg+xml"
223+ _ -> Nothing
224+
225+pageTemplate :: String
226+pageTemplate = unlines
227+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
228+ , "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"
229+ , "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
230+ , "<head>"
231+ , "<title>$title$</title>"
232+ , "<link href=\"stylesheet.css\" type=\"text/css\" rel=\"stylesheet\" />"
233+ , "</head>"
234+ , "<body>"
235+ , "$if(titlepage)$"
236+ , "<h1 class=\"title\">$title$</h1>"
237+ , "$for(author)$"
238+ , "<h2 class=\"author\">$author$</h2>"
239+ , "$endfor$"
240+ , "$else$"
241+ , "<h1>$title$</h1>"
242+ , "$body$"
243+ , "$endif$"
244+ , "</body>"
245+ , "</html>"
246+ ]
247+