@@ -0,0 +1,570 @@
2+Copyright (c) 2011-2012, Sergey Astanin
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20+{- | Conversion of 'Pandoc' documents to FB2 (FictionBook2) format.
22+FictionBook is an XML-based e-book format. For more information see:
23+<http://www.fictionbook.org/index.php/Eng:XML_Schema_Fictionbook_2.1>
26+module Text.Pandoc.Writers.FB2 (writeFB2) where
28+import Control.Monad.State (StateT, evalStateT, get, modify)
29+import Control.Monad.State (liftM, liftM2, liftIO)
30+import Data.ByteString.Base64 (encode)
31+import Data.Char (toUpper, toLower, isSpace)
32+import Data.List (intersperse, intercalate)
33+import Data.Either (lefts, rights)
34+import Network.Browser (browse, request, setAllowRedirects, setOutHandler)
35+import Network.HTTP (catchIO_, getRequest, getHeaders, getResponseBody)
36+import Network.HTTP (lookupHeader, HeaderName(..), urlEncode)
37+import Network.URI (isURI, unEscapeString)
38+import System.FilePath (takeExtension)
40+import qualified Control.Exception as E
41+import qualified Data.ByteString as B
42+import qualified Text.XML.Light as X
43+import qualified Text.XML.Light.Cursor as XC
45+import Text.Pandoc.Definition
46+import Text.Pandoc.Shared (WriterOptions(..), HTMLMathMethod(..))
47+import Text.Pandoc.Shared (orderedListMarkers, defaultWriterOptions)
48+import Text.Pandoc.Generic (bottomUp)
50+-- | Data to be written at the end of the document:
51+-- (foot)notes, URLs, references, images.
52+data FbRenderState = FbRenderState
53+ { footnotes :: [ (Int, String, [Content]) ] -- ^ #, ID, text
54+ , imagesToFetch :: [ (String, String) ] -- ^ filename, URL or path
55+ , parentListMarker :: String -- ^ list marker of the parent ordered list
56+ , parentBulletLevel :: Int -- ^ nesting level of the unordered list
57+ , writerOptions :: WriterOptions
60+-- | FictionBook building monad.
61+type FBM = StateT FbRenderState IO
63+newFB :: FbRenderState
64+newFB = FbRenderState { footnotes = [], imagesToFetch = []
65+ , parentListMarker = "", parentBulletLevel = 0
66+ , writerOptions = defaultWriterOptions }
68+data ImageMode = NormalImage | InlineImage deriving (Eq)
69+instance Show ImageMode where
70+ show NormalImage = "imageType"
71+ show InlineImage = "inlineImageType"
73+-- | Produce an FB2 document from a 'Pandoc' document.
74+writeFB2 :: WriterOptions -- ^ conversion options
75+ -> Pandoc -- ^ document to convert
76+ -> IO String -- ^ FictionBook2 document (not encoded yet)
77+writeFB2 opts (Pandoc meta blocks) = flip evalStateT newFB $ do
78+ modify (\s -> s { writerOptions = opts { writerStandalone = True } })
79+ desc <- description meta
81+ secs <- renderSections 1 blocks
82+ let body = el "body" $ fp ++ secs
83+ notes <- renderFootnotes
84+ (imgs,missing) <- liftM imagesToFetch get >>= \s -> liftIO (fetchImages s)
85+ let body' = replaceImagesWithAlt missing body
86+ let fb2_xml = el "FictionBook" (fb2_attrs, [desc, body'] ++ notes ++ imgs)
87+ return $ xml_head ++ (showContent fb2_xml)
89+ xml_head = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
91+ let xmlns = "http://www.gribuser.ru/xml/fictionbook/2.0"
92+ xlink = "http://www.w3.org/1999/xlink"
93+ in [ uattr "xmlns" xmlns
94+ , attr ("xmlns", "l") xlink ]
96+ frontpage :: Meta -> FBM [Content]
98+ t <- cMapM toXml . docTitle $ meta'
100+ [ el "title" (el "p" t)
101+ , el "annotation" (map (el "p" . cMap plain)
102+ (docAuthors meta' ++ [docDate meta']))
104+ description :: Meta -> FBM Content
105+ description meta' = do
106+ bt <- booktitle meta'
107+ let as = authors meta'
109+ return $ el "description"
110+ [ el "title-info" (bt ++ as ++ dd)
111+ , el "document-info" [ el "program-used" "pandoc" ] -- FIXME: +version
113+ booktitle :: Meta -> FBM [Content]
114+ booktitle meta' = do
115+ t <- cMapM toXml . docTitle $ meta'
118+ else [ el "book-title" t ]
119+ authors :: Meta -> [Content]
120+ authors meta' = cMap author (docAuthors meta')
121+ author :: [Inline] -> [Content]
123+ let ws = words . cMap plain $ ss
124+ email = (el "email") `fmap` (take 1 $ filter ('@' `elem`) ws)
125+ ws' = filter ('@' `notElem`) ws
127+ (nickname:[]) -> [ el "nickname" nickname ]
128+ (fname:lname:[]) -> [ el "first-name" fname
129+ , el "last-name" lname ]
130+ (fname:rest) -> [ el "first-name" fname
131+ , el "middle-name" (concat . init $ rest)
132+ , el "last-name" (last rest) ]
134+ in list $ el "author" (names ++ email)
135+ docdate :: Meta -> FBM [Content]
137+ let ss = docDate meta'
143+-- | Divide the stream of blocks into sections and convert to XML
145+renderSections :: Int -> [Block] -> FBM [Content]
146+renderSections level blocks = do
147+ let secs = splitSections level blocks
148+ mapM (renderSection level) secs
150+renderSection :: Int -> ([Inline], [Block]) -> FBM Content
151+renderSection level (ttl, body) = do
152+ title <- if null ttl
154+ else return . list . el "title" . formatTitle $ ttl
155+ content <- if (hasSubsections body)
156+ then renderSections (level + 1) body
157+ else cMapM blockToXml body
158+ return $ el "section" (title ++ content)
160+ hasSubsections = any isHeader
161+ isHeader (Header _ _) = True
164+-- | Only <p> and <empty-line> are allowed within <title> in FB2.
165+formatTitle :: [Inline] -> [Content]
166+formatTitle inlines =
167+ let lns = split isLineBreak inlines
168+ lns' = map (el "p" . cMap plain) lns
169+ in intersperse (el "empty-line" ()) lns'
171+split :: (a -> Bool) -> [a] -> [[a]]
173+split cond xs = let (b,a) = break cond xs
174+ in (b:split cond (drop 1 a))
176+isLineBreak :: Inline -> Bool
177+isLineBreak LineBreak = True
178+isLineBreak _ = False
180+-- | Divide the stream of block elements into sections: [(title, blocks)].
181+splitSections :: Int -> [Block] -> [([Inline], [Block])]
182+splitSections level blocks = reverse $ revSplit (reverse blocks)
186+ let (lastsec, before) = break sameLevel rblocks
187+ (header, prevblocks) =
189+ ((Header n title):prevblocks') ->
191+ then (title, prevblocks')
194+ in (header, reverse lastsec) : revSplit prevblocks
195+ sameLevel (Header n _) = n == level
198+-- | Make another FictionBook body with footnotes.
199+renderFootnotes :: FBM [Content]
201+ fns <- footnotes `liftM` get
203+ then return [] -- no footnotes
204+ else return . list $
205+ el "body" ([uattr "name" "notes"], map renderFN (reverse fns))
207+ renderFN (n, idstr, cs) =
208+ let fn_texts = (el "title" (el "p" (show n))) : cs
209+ in el "section" ([uattr "id" idstr], fn_texts)
211+-- | Fetch images and encode them for the FictionBook XML.
212+-- Return image data and a list of hrefs of the missing images.
213+fetchImages :: [(String,String)] -> IO ([Content],[String])
214+fetchImages links = do
215+ imgs <- mapM (uncurry fetchImage) links
216+ return $ (rights imgs, lefts imgs)
218+-- | Fetch image data from disk or from network and make a <binary> XML section.
219+-- Return either (Left hrefOfMissingImage) or (Right xmlContent).
220+fetchImage :: String -> String -> IO (Either String Content)
221+fetchImage href link = do
226+ d <- nothingOnError $ B.readFile (unEscapeString link)
227+ let t = case map toLower (takeExtension link) of
228+ ".png" -> Just "image/png"
229+ ".jpg" -> Just "image/jpeg"
230+ ".jpeg" -> Just "image/jpeg"
231+ ".jpe" -> Just "image/jpeg"
232+ _ -> Nothing -- only PNG and JPEG are supported in FB2
233+ return $ liftM2 (,) t d
235+ Just (imgtype, imgdata) -> do
236+ let encdata = encode imgdata
237+ let encstr = map (toEnum . fromEnum) . B.unpack $ encdata
238+ return . Right $ el "binary"
240+ , uattr "content-type" imgtype]
242+ _ -> return (Left ('#':href))
244+ nothingOnError :: (IO B.ByteString) -> (IO (Maybe B.ByteString))
245+ nothingOnError action = liftM Just action `E.catch` omnihandler
246+ omnihandler :: E.SomeException -> IO (Maybe B.ByteString)
247+ omnihandler _ = return Nothing
249+-- | Fetch URL, return its Content-Type and binary data on success.
250+fetchURL :: String -> IO (Maybe (String, B.ByteString))
252+ flip catchIO_ (return Nothing) $ do
254+ setOutHandler (const (return ()))
255+ setAllowRedirects True
256+ liftM snd . request . getRequest $ url
257+ let content_type = lookupHeader HdrContentType (getHeaders r)
258+ content <- liftM (Just . toBS) . getResponseBody $ Right r
259+ return $ liftM2 (,) content_type content
261+ toBS = B.pack . map (toEnum . fromEnum)
263+footnoteID :: Int -> String
264+footnoteID i = "n" ++ (show i)
266+linkID :: Int -> String
267+linkID i = "l" ++ (show i)
269+-- | Convert a block-level Pandoc's element to FictionBook XML representation.
270+blockToXml :: Block -> FBM [Content]
271+blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2
272+blockToXml (Para [Math DisplayMath formula]) = insertMath NormalImage formula
273+blockToXml (Para [img@(Image _ _)]) = insertImage NormalImage img
274+blockToXml (Para ss) = liftM (list . el "p") $ cMapM toXml ss
275+blockToXml (CodeBlock _ s) = return . spaceBeforeAfter .
276+ map (el "p" . el "code") . lines $ s
277+blockToXml (RawBlock _ s) = return . spaceBeforeAfter .
278+ map (el "p" . el "code") . lines $ s
279+blockToXml (BlockQuote bs) = liftM (list . el "cite") $ cMapM blockToXml bs
280+blockToXml (OrderedList a bss) = do
282+ let pmrk = parentListMarker state
283+ let markers = map ((pmrk ++ " ") ++) $ orderedListMarkers a
284+ let mkitem mrk bs = do
285+ modify (\s -> s { parentListMarker = mrk })
286+ itemtext <- cMapM blockToXml . paraToPlain $ bs
287+ modify (\s -> s { parentListMarker = pmrk }) -- old parent marker
288+ return . el "p" $ [ txt mrk, txt " " ] ++ itemtext
289+ mapM (uncurry mkitem) (zip markers bss)
290+blockToXml (BulletList bss) = do
292+ let level = parentBulletLevel state
293+ let pmrk = parentListMarker state
294+ let prefix = replicate (length pmrk) ' '
295+ let bullets = ["\x2022", "\x25e6", "*", "\x2043", "\x2023"]
296+ let mrk = prefix ++ bullets !! (level `mod` (length bullets))
298+ modify (\s -> s { parentBulletLevel = (level+1) })
299+ itemtext <- cMapM blockToXml . paraToPlain $ bs
300+ modify (\s -> s { parentBulletLevel = level }) -- restore bullet level
301+ return $ el "p" $ [ txt (mrk ++ " ") ] ++ itemtext
303+blockToXml (DefinitionList defs) =
306+ mkdef (term, bss) = do
307+ def <- cMapM (cMapM blockToXml . sep . paraToPlain . map indent) bss
308+ t <- wrap "strong" term
309+ return [ el "p" t, el "p" def ]
311+ if all needsBreak blocks then
312+ blocks ++ [Plain [LineBreak]]
315+ needsBreak (Para _) = False
316+ needsBreak (Plain ins) = LineBreak `notElem` ins
318+blockToXml (Header _ _) = -- should never happen, see renderSections
319+ error "unexpected header in section text"
320+blockToXml HorizontalRule = return
321+ [ el "empty-line" ()
322+ , el "p" (txt (replicate 10 '—'))
323+ , el "empty-line" () ]
324+blockToXml (Table caption aligns _ headers rows) = do
325+ hd <- mkrow "th" headers aligns
326+ bd <- mapM (\r -> mkrow "td" r aligns) rows
327+ c <- return . el "emphasis" =<< cMapM toXml caption
328+ return [el "table" (hd : bd), el "p" c]
330+ mkrow :: String -> [TableCell] -> [Alignment] -> FBM Content
331+ mkrow tag cells aligns' =
332+ (el "tr") `liftM` (mapM (mkcell tag) (zip cells aligns'))
334+ mkcell :: String -> (TableCell, Alignment) -> FBM Content
335+ mkcell tag (cell, align) = do
336+ cblocks <- cMapM blockToXml cell
337+ return $ el tag ([align_attr align], cblocks)
339+ align_attr a = Attr (QName "align" Nothing Nothing) (align_str a)
340+ align_str AlignLeft = "left"
341+ align_str AlignCenter = "center"
342+ align_str AlignRight = "right"
343+ align_str AlignDefault = "left"
344+blockToXml Null = return []
346+-- Replace paragraphs with plain text and line break.
347+-- Necessary to simulate multi-paragraph lists in FB2.
348+paraToPlain :: [Block] -> [Block]
350+paraToPlain (Para inlines : rest) =
351+ let p = (Plain (inlines ++ [LineBreak]))
352+ in p : paraToPlain rest
353+paraToPlain (p:rest) = p : paraToPlain rest
355+-- Simulate increased indentation level. Will not really work
356+-- for multi-line paragraphs.
357+indent :: Block -> Block
360+ -- indentation space
362+ spacer = replicate 4 ' '
364+ indentBlock (Plain ins) = Plain ((Str spacer):ins)
365+ indentBlock (Para ins) = Para ((Str spacer):ins)
366+ indentBlock (CodeBlock a s) =
367+ let s' = unlines . map (spacer++) . lines $ s
369+ indentBlock (BlockQuote bs) = BlockQuote (map indent bs)
370+ indentBlock (Header l ins) = Header l (indentLines ins)
371+ indentBlock everythingElse = everythingElse
372+ -- indent every (explicit) line
373+ indentLines :: [Inline] -> [Inline]
374+ indentLines ins = let lns = split isLineBreak ins :: [[Inline]]
375+ in intercalate [LineBreak] $ map ((Str spacer):) lns
377+-- | Convert a Pandoc's Inline element to FictionBook XML representation.
378+toXml :: Inline -> FBM [Content]
379+toXml (Str s) = return [txt s]
380+toXml (Emph ss) = list `liftM` wrap "emphasis" ss
381+toXml (Strong ss) = list `liftM` wrap "strong" ss
382+toXml (Strikeout ss) = list `liftM` wrap "strikethrough" ss
383+toXml (Superscript ss) = list `liftM` wrap "sup" ss
384+toXml (Subscript ss) = list `liftM` wrap "sub" ss
385+toXml (SmallCaps ss) = cMapM toXml $ bottomUp (map toUpper) ss
386+toXml (Quoted SingleQuote ss) = do -- FIXME: should be language-specific
387+ inner <- cMapM toXml ss
388+ return $ [txt "‘"] ++ inner ++ [txt "’"]
389+toXml (Quoted DoubleQuote ss) = do
390+ inner <- cMapM toXml ss
391+ return $ [txt "“"] ++ inner ++ [txt "”"]
392+toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles
393+toXml (Code _ s) = return [el "code" s]
394+toXml Space = return [txt " "]
395+toXml LineBreak = return [el "empty-line" ()]
396+toXml (Math _ formula) = insertMath InlineImage formula
397+toXml (RawInline _ _) = return [] -- raw TeX and raw HTML are suppressed
398+toXml (Link text (url,ttl)) = do
399+ fns <- footnotes `liftM` get
400+ let n = 1 + length fns
401+ let ln_id = linkID n
402+ let ln_ref = list . el "sup" . txt $ "[" ++ show n ++ "]"
403+ ln_text <- cMapM toXml text
405+ let ttl' = dropWhile isSpace ttl
407+ then list . el "p" $ el "code" url
408+ else list . el "p" $ [ txt (ttl' ++ ": "), el "code" url ]
409+ modify (\s -> s { footnotes = (n, ln_id, ln_desc) : fns })
412+ ( [ attr ("l","href") ('#':ln_id)
413+ , uattr "type" "note" ]
415+toXml img@(Image _ _) = insertImage InlineImage img
417+ fns <- footnotes `liftM` get
418+ let n = 1 + length fns
419+ let fn_id = footnoteID n
420+ fn_desc <- cMapM blockToXml bs
421+ modify (\s -> s { footnotes = (n, fn_id, fn_desc) : fns })
422+ let fn_ref = el "sup" . txt $ "[" ++ show n ++ "]"
423+ return . list $ el "a" ( [ attr ("l","href") ('#':fn_id)
424+ , uattr "type" "note" ]
427+insertMath :: ImageMode -> String -> FBM [Content]
428+insertMath immode formula = do
429+ htmlMath <- return . writerHTMLMathMethod . writerOptions =<< get
432+ let alt = [Code nullAttr formula]
433+ let imgurl = url ++ urlEncode formula
434+ let img = Image alt (imgurl, "")
435+ insertImage immode img
436+ _ -> return [el "code" formula]
438+insertImage :: ImageMode -> Inline -> FBM [Content]
439+insertImage immode (Image alt (url,ttl)) = do
440+ images <- imagesToFetch `liftM` get
441+ let n = 1 + length images
442+ let fname = "image" ++ show n
443+ modify (\s -> s { imagesToFetch = (fname, url) : images })
444+ let ttlattr = case (immode, null ttl) of
445+ (NormalImage, False) -> [ uattr "title" ttl ]
449+ [ attr ("l","href") ('#':fname)
450+ , attr ("l","type") (show immode)
451+ , uattr "alt" (cMap plain alt) ]
453+insertImage _ _ = error "unexpected inline instead of image"
455+replaceImagesWithAlt :: [String] -> Content -> Content
456+replaceImagesWithAlt missingHrefs body =
457+ let cur = XC.fromContent body
458+ cur' = replaceAll cur
459+ in XC.toTree . XC.root $ cur'
462+ replaceAll :: XC.Cursor -> XC.Cursor
464+ let n = XC.current c
465+ c' = if isImage n && isMissing n
466+ then XC.modifyContent replaceNode c
468+ in case XC.nextDF c' of
469+ (Just cnext) -> replaceAll cnext
470+ Nothing -> c' -- end of document
472+ isImage :: Content -> Bool
473+ isImage (Elem e) = (elName e) == (uname "image")
476+ isMissing (Elem img@(Element _ _ _ _)) =
477+ let imgAttrs = elAttribs img
478+ badAttrs = map (attr ("l","href")) missingHrefs
479+ in any (`elem` imgAttrs) badAttrs
482+ replaceNode :: Content -> Content
483+ replaceNode n@(Elem img@(Element _ _ _ _)) =
484+ let attrs = elAttribs img
485+ alt = getAttrVal attrs (uname "alt")
486+ imtype = getAttrVal attrs (qname "l" "type")
487+ in case (alt, imtype) of
488+ (Just alt', Just imtype') ->
489+ if imtype' == show NormalImage
492+ (Just alt', Nothing) -> txt alt' -- no type attribute
493+ _ -> n -- don't replace if alt text is not found
496+ getAttrVal :: [X.Attr] -> QName -> Maybe String
497+ getAttrVal attrs name =
498+ case filter ((name ==) . attrKey) attrs of
499+ (a:_) -> Just (attrVal a)
503+-- | Wrap all inlines with an XML tag (given its unqualified name).
504+wrap :: String -> [Inline] -> FBM Content
505+wrap tagname inlines = el tagname `liftM` cMapM toXml inlines
507+-- " Create a singleton list.
511+-- | Convert an 'Inline' to plaintext.
512+plain :: Inline -> String
514+plain (Emph ss) = concat (map plain ss)
515+plain (Strong ss) = concat (map plain ss)
516+plain (Strikeout ss) = concat (map plain ss)
517+plain (Superscript ss) = concat (map plain ss)
518+plain (Subscript ss) = concat (map plain ss)
519+plain (SmallCaps ss) = concat (map plain ss)
520+plain (Quoted _ ss) = concat (map plain ss)
521+plain (Cite _ ss) = concat (map plain ss) -- FIXME
524+plain LineBreak = "\n"
526+plain (RawInline _ s) = s
527+plain (Link text (url,_)) = concat (map plain text ++ [" <", url, ">"])
528+plain (Image alt _) = concat (map plain alt)
529+plain (Note _) = "" -- FIXME
531+-- | Create an XML element.
533+ => String -- ^ unqualified element name
534+ -> t -- ^ node contents
535+ -> Content -- ^ XML content
536+el name cs = Elem $ unode name cs
538+-- | Put empty lines around content
539+spaceBeforeAfter :: [Content] -> [Content]
540+spaceBeforeAfter cs =
541+ let emptyline = el "empty-line" ()
542+ in [emptyline] ++ cs ++ [emptyline]
544+-- | Create a plain-text XML content.
545+txt :: String -> Content
546+txt s = Text $ CData CDataText s Nothing
548+-- | Create an XML attribute with an unqualified name.
549+uattr :: String -> String -> Text.XML.Light.Attr
550+uattr name val = Attr (uname name) val
552+-- | Create an XML attribute with a qualified name from given namespace.
553+attr :: (String, String) -> String -> Text.XML.Light.Attr
554+attr (ns, name) val = Attr (qname ns name) val
556+-- | Unqualified name
557+uname :: String -> QName
558+uname name = QName name Nothing Nothing
561+qname :: String -> String -> QName
562+qname ns name = QName name Nothing (Just ns)
564+-- | Abbreviation for 'concatMap'.
565+cMap :: (a -> [b]) -> [a] -> [b]
568+-- | Monadic equivalent of 'concatMap'.
569+cMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
570+cMapM f xs = concat `liftM` mapM f xs