@@ -0,0 +1,402 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE TupleSections #-}
3+{-
4+Copyright (C) 2018 Alexander Krotov <ilabdsf@gmail.com>
5+
6+This program is free software; you can redistribute it and/or modify
7+it under the terms of the GNU General Public License as published by
8+the Free Software Foundation; either version 2 of the License, or
9+(at your option) any later version.
10+
11+This program is distributed in the hope that it will be useful,
12+but WITHOUT ANY WARRANTY; without even the implied warranty of
13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14+GNU General Public License for more details.
15+
16+You should have received a copy of the GNU General Public License
17+along with this program; if not, write to the Free Software
18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19+-}
20+
21+{- |
22+ Module : Text.Pandoc.Readers.FB2
23+ Copyright : Copyright (C) 2018 Alexander Krotov
24+ License : GNU GPL, version 2 or above
25+
26+ Maintainer : Alexander Krotov <ilabdsf@gmail.com>
27+ Stability : alpha
28+ Portability : portable
29+
30+Conversion of FB2 to 'Pandoc' document.
31+-}
32+
33+{-
34+
35+TODO:
36+ - Tables
37+ - Named styles
38+ - Parse ID attribute for all elements that have it
39+
40+-}
41+
42+module Text.Pandoc.Readers.FB2 ( readFB2 ) where
43+import Prelude
44+import Control.Monad.Except (throwError)
45+import Control.Monad.State.Strict
46+import Data.ByteString.Lazy.Char8 ( pack )
47+import Data.ByteString.Base64.Lazy
48+import Data.Char (isSpace, toUpper)
49+import Data.List (dropWhileEnd, intersperse)
50+import Data.List.Split (splitOn)
51+import Data.Text (Text)
52+import Data.Default
53+import Data.Maybe
54+import Text.HTML.TagSoup.Entity (lookupEntity)
55+import Text.Pandoc.Builder
56+import Text.Pandoc.Class (PandocMonad, insertMedia)
57+import Text.Pandoc.Error
58+import Text.Pandoc.Options
59+import Text.Pandoc.Shared (crFilter)
60+import Text.XML.Light
61+
62+type FB2 m = StateT FB2State m
63+
64+data FB2State = FB2State{ fb2SectionLevel :: Int
65+ , fb2Meta :: Meta
66+ , fb2Authors :: [String]
67+ } deriving Show
68+
69+instance Default FB2State where
70+ def = FB2State{ fb2SectionLevel = 1
71+ , fb2Meta = mempty
72+ , fb2Authors = []
73+ }
74+
75+instance HasMeta FB2State where
76+ setMeta field v s = s {fb2Meta = setMeta field v (fb2Meta s)}
77+ deleteMeta field s = s {fb2Meta = deleteMeta field (fb2Meta s)}
78+
79+readFB2 :: PandocMonad m => ReaderOptions -> Text -> m Pandoc
80+readFB2 _ inp = do
81+ (bs, st) <- runStateT (mapM parseBlock $ parseXML (crFilter inp)) def
82+ let authors = if null $ fb2Authors st
83+ then id
84+ else setMeta "author" (map text $ reverse $ fb2Authors st)
85+ pure $ Pandoc (authors $ fb2Meta st) (toList . mconcat $ bs)
86+
87+-- * Utility functions
88+
89+trim :: String -> String
90+trim = dropWhileEnd isSpace . dropWhile isSpace
91+
92+removeHash :: String -> String
93+removeHash ('#':xs) = xs
94+removeHash xs = xs
95+
96+convertEntity :: String -> String
97+convertEntity e = fromMaybe (map toUpper e) (lookupEntity e)
98+
99+parseInline :: PandocMonad m => Content -> FB2 m Inlines
100+parseInline (Elem e) =
101+ case qName $ elName e of
102+ "strong" -> strong <$> parseStyleType e
103+ "emphasis" -> emph <$> parseStyleType e
104+ "style" -> parseNamedStyle e
105+ "a" -> parseLinkType e
106+ "strikethrough" -> strikeout <$> parseStyleType e
107+ "sub" -> subscript <$> parseStyleType e
108+ "sup" -> superscript <$> parseStyleType e
109+ "code" -> pure $ code $ strContent e
110+ "image" -> parseInlineImageElement e
111+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ ".")
112+parseInline (Text x) = pure $ text $ cdData x
113+parseInline (CRef r) = pure $ str $ convertEntity r
114+
115+parseSubtitle :: PandocMonad m => Element -> FB2 m Blocks
116+parseSubtitle e = headerWith ("", ["unnumbered"], []) <$> gets fb2SectionLevel <*> parsePType e
117+
118+-- * Root element parser
119+
120+parseBlock :: PandocMonad m => Content -> FB2 m Blocks
121+parseBlock (Elem e) =
122+ case qName $ elName e of
123+ "?xml" -> pure mempty
124+ "FictionBook" -> mconcat <$> mapM parseFictionBookChild (elChildren e)
125+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ ".")
126+parseBlock _ = pure mempty
127+
128+-- | Parse a child of @\<FictionBook>@ element.
129+parseFictionBookChild :: PandocMonad m => Element -> FB2 m Blocks
130+parseFictionBookChild e =
131+ case qName $ elName e of
132+ "stylesheet" -> pure mempty -- stylesheet is ignored
133+ "description" -> mempty <$ mapM_ parseDescriptionChild (elChildren e)
134+ "body" -> mconcat <$> mapM parseBodyChild (elChildren e)
135+ "binary" -> mempty <$ parseBinaryElement e
136+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ "in FictionBook.")
137+
138+-- | Parse a child of @\<description>@ element.
139+parseDescriptionChild :: PandocMonad m => Element -> FB2 m ()
140+parseDescriptionChild e =
141+ case qName $ elName e of
142+ "title-info" -> mapM_ parseTitleInfoChild (elChildren e)
143+ "src-title-info" -> pure () -- ignore
144+ "document-info" -> pure ()
145+ "publish-info" -> pure ()
146+ "custom-info" -> pure ()
147+ "output" -> pure ()
148+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ "in description.")
149+
150+-- | Parse a child of @\<body>@ element.
151+parseBodyChild :: PandocMonad m => Element -> FB2 m Blocks
152+parseBodyChild e =
153+ case qName $ elName e of
154+ "image" -> parseImageElement e
155+ "title" -> header <$> gets fb2SectionLevel <*> parseTitleType (elContent e)
156+ "epigraph" -> parseEpigraph e
157+ "section" -> parseSection e
158+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in body.")
159+
160+-- | Parse a @\<binary>@ element.
161+parseBinaryElement :: PandocMonad m => Element -> FB2 m ()
162+parseBinaryElement e =
163+ case (findAttr (QName "id" Nothing Nothing) e, findAttr (QName "content-type" Nothing Nothing) e) of
164+ (Nothing, _) -> throwError $ PandocParseError "<binary> element must have an \"id\" attribute"
165+ (Just _, Nothing) -> throwError $ PandocParseError "<binary> element must have a \"content-type\" attribute"
166+ (Just filename, contentType) -> insertMedia filename contentType (decodeLenient (pack (strContent e)))
167+
168+-- * Type parsers
169+
170+-- | Parse @authorType@
171+parseAuthor :: PandocMonad m => Element -> FB2 m String
172+parseAuthor e = unwords <$> mapM parseAuthorChild (elChildren e)
173+
174+parseAuthorChild :: PandocMonad m => Element -> FB2 m String
175+parseAuthorChild e =
176+ case qName $ elName e of
177+ "first-name" -> pure $ strContent e
178+ "middle-name" -> pure $ strContent e
179+ "last-name" -> pure $ strContent e
180+ "nickname" -> pure $ strContent e
181+ "home-page" -> pure $ strContent e
182+ "email" -> pure $ strContent e
183+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in author.")
184+
185+-- | Parse @titleType@
186+parseTitle :: PandocMonad m => Element -> FB2 m Blocks
187+parseTitle e = header <$> gets fb2SectionLevel <*> parseTitleType (elContent e)
188+
189+parseTitleType :: PandocMonad m => [Content] -> FB2 m Inlines
190+parseTitleType c = mconcat . intersperse linebreak . catMaybes <$> mapM parseTitleContent c
191+
192+parseTitleContent :: PandocMonad m => Content -> FB2 m (Maybe Inlines)
193+parseTitleContent (Elem e) =
194+ case qName $ elName e of
195+ "p" -> Just <$> parsePType e
196+ "empty-line" -> pure $ Just mempty
197+ _ -> pure mempty
198+parseTitleContent _ = pure Nothing
199+
200+-- | Parse @imageType@
201+parseImageElement :: PandocMonad m => Element -> FB2 m Blocks
202+parseImageElement e =
203+ case href of
204+ Just src -> pure $ para $ imageWith (imgId, [], []) (removeHash src) title alt
205+ Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: image without href."
206+ where alt = maybe mempty str $ findAttr (QName "alt" Nothing Nothing) e
207+ title = fromMaybe "" $ findAttr (QName "title" Nothing Nothing) e
208+ imgId = fromMaybe "" $ findAttr (QName "id" Nothing Nothing) e
209+ href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e
210+
211+-- | Parse @pType@
212+parsePType :: PandocMonad m => Element -> FB2 m Inlines
213+parsePType = parseStyleType -- TODO add support for optional "id" and "style" attributes
214+
215+-- | Parse @citeType@
216+parseCite :: PandocMonad m => Element -> FB2 m Blocks
217+parseCite e = blockQuote . mconcat <$> mapM parseCiteChild (elChildren e)
218+
219+-- | Parse @citeType@ child
220+parseCiteChild :: PandocMonad m => Element -> FB2 m Blocks
221+parseCiteChild e =
222+ case qName $ elName e of
223+ "p" -> para <$> parsePType e
224+ "poem" -> parsePoem e
225+ "empty-line" -> pure horizontalRule
226+ "subtitle" -> parseSubtitle e
227+ "table" -> parseTable e
228+ "text-author" -> para <$> parsePType e
229+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in cite.")
230+
231+-- | Parse @poemType@
232+parsePoem :: PandocMonad m => Element -> FB2 m Blocks
233+parsePoem e = mconcat <$> mapM parsePoemChild (elChildren e)
234+
235+parsePoemChild :: PandocMonad m => Element -> FB2 m Blocks
236+parsePoemChild e =
237+ case qName $ elName e of
238+ "title" -> parseTitle e
239+ "subtitle" -> parseSubtitle e
240+ "epigraph" -> parseEpigraph e
241+ "stanza" -> parseStanza e
242+ "text-author" -> para <$> parsePType e
243+ "date" -> pure $ para $ text $ strContent e
244+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in poem.")
245+
246+parseStanza :: PandocMonad m => Element -> FB2 m Blocks
247+parseStanza e = fromList . joinLineBlocks . toList . mconcat <$> mapM parseStanzaChild (elChildren e)
248+
249+joinLineBlocks :: [Block] -> [Block]
250+joinLineBlocks (LineBlock xs:LineBlock ys:zs) = joinLineBlocks (LineBlock (xs ++ ys) : zs)
251+joinLineBlocks (x:xs) = x:joinLineBlocks xs
252+joinLineBlocks [] = []
253+
254+parseStanzaChild :: PandocMonad m => Element -> FB2 m Blocks
255+parseStanzaChild e =
256+ case qName $ elName e of
257+ "title" -> parseTitle e
258+ "subtitle" -> parseSubtitle e
259+ "v" -> lineBlock . (:[]) <$> parsePType e
260+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in stanza.")
261+
262+-- | Parse @epigraphType@
263+parseEpigraph :: PandocMonad m => Element -> FB2 m Blocks
264+parseEpigraph e =
265+ divWith (divId, ["epigraph"], []) . mconcat <$> mapM parseEpigraphChild (elChildren e)
266+ where divId = fromMaybe "" $ findAttr (QName "id" Nothing Nothing) e
267+
268+parseEpigraphChild :: PandocMonad m => Element -> FB2 m Blocks
269+parseEpigraphChild e =
270+ case qName $ elName e of
271+ "p" -> para <$> parsePType e
272+ "poem" -> parsePoem e
273+ "cite" -> parseCite e
274+ "empty-line" -> pure horizontalRule
275+ "text-author" -> para <$> parsePType e
276+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in epigraph.")
277+
278+-- | Parse @annotationType@
279+parseAnnotation :: PandocMonad m => Element -> FB2 m Blocks
280+parseAnnotation e = mconcat <$> mapM parseAnnotationChild (elChildren e)
281+
282+parseAnnotationChild :: PandocMonad m => Element -> FB2 m Blocks
283+parseAnnotationChild e =
284+ case qName $ elName e of
285+ "p" -> para <$> parsePType e
286+ "poem" -> parsePoem e
287+ "cite" -> parseCite e
288+ "subtitle" -> parseSubtitle e
289+ "table" -> parseTable e
290+ "empty-line" -> pure horizontalRule
291+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in annotation.")
292+
293+-- | Parse @sectionType@
294+parseSection :: PandocMonad m => Element -> FB2 m Blocks
295+parseSection e = do
296+ n <- gets fb2SectionLevel
297+ modify $ \st -> st{ fb2SectionLevel = n + 1 }
298+ let sectionId = fromMaybe "" $ findAttr (QName "id" Nothing Nothing) e
299+ bs <- divWith (sectionId, ["section"], []) . mconcat <$> mapM parseSectionChild (elChildren e)
300+ modify $ \st -> st{ fb2SectionLevel = n }
301+ pure bs
302+
303+parseSectionChild :: PandocMonad m => Element -> FB2 m Blocks
304+parseSectionChild e =
305+ case qName $ elName e of
306+ "title" -> parseBodyChild e
307+ "epigraph" -> parseEpigraph e
308+ "image" -> parseImageElement e
309+ "annotation" -> parseAnnotation e
310+ "poem" -> parsePoem e
311+ "cite" -> parseCite e
312+ "empty-line" -> pure horizontalRule
313+ "table" -> parseTable e
314+ "subtitle" -> parseSubtitle e
315+ "p" -> para <$> parsePType e
316+ "section" -> parseSection e
317+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in section.")
318+
319+-- | parse @styleType@
320+parseStyleType :: PandocMonad m => Element -> FB2 m Inlines
321+parseStyleType e = mconcat <$> mapM parseInline (elContent e)
322+
323+-- | Parse @namedStyleType@
324+parseNamedStyle :: PandocMonad m => Element -> FB2 m Inlines
325+parseNamedStyle e = do
326+ content <- mconcat <$> mapM parseNamedStyleChild (elContent e)
327+ let lang = maybeToList $ ("lang",) <$> findAttr (QName "lang" Nothing (Just "xml")) e
328+ case findAttr (QName "name" Nothing Nothing) e of
329+ Just name -> pure $ spanWith ("", [name], lang) content
330+ Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: link without required name."
331+
332+parseNamedStyleChild :: PandocMonad m => Content -> FB2 m Inlines
333+parseNamedStyleChild (Elem e) =
334+ case qName (elName e) of
335+ "strong" -> strong <$> parseStyleType e
336+ "emphasis" -> emph <$> parseStyleType e
337+ "style" -> parseNamedStyle e
338+ "a" -> parseLinkType e
339+ "strikethrough" -> strikeout <$> parseStyleType e
340+ "sub" -> subscript <$> parseStyleType e
341+ "sup" -> superscript <$> parseStyleType e
342+ "code" -> pure $ code $ strContent e
343+ "image" -> parseInlineImageElement e
344+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ ".")
345+parseNamedStyleChild x = parseInline x
346+
347+-- | Parse @linkType@
348+parseLinkType :: PandocMonad m => Element -> FB2 m Inlines
349+parseLinkType e = do
350+ content <- mconcat <$> mapM parseStyleLinkType (elContent e)
351+ case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
352+ Just href -> pure $ link href "" content
353+ Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: link without required href."
354+
355+-- | Parse @styleLinkType@
356+parseStyleLinkType :: PandocMonad m => Content -> FB2 m Inlines
357+parseStyleLinkType x@(Elem e) =
358+ case qName (elName e) of
359+ "a" -> throwError $ PandocParseError "Couldn't parse FB2 file: links cannot be nested."
360+ _ -> parseInline x
361+parseStyleLinkType x = parseInline x
362+
363+-- | Parse @tableType@
364+parseTable :: PandocMonad m => Element -> FB2 m Blocks
365+parseTable _ = pure mempty -- TODO: tables are not supported yet
366+
367+-- | Parse @title-infoType@
368+parseTitleInfoChild :: PandocMonad m => Element -> FB2 m ()
369+parseTitleInfoChild e =
370+ case qName (elName e) of
371+ "genre" -> pure ()
372+ "author" -> parseAuthor e >>= \author -> modify (\st -> st {fb2Authors = author:fb2Authors st})
373+ "book-title" -> modify (setMeta "title" (text $ strContent e))
374+ "annotation" -> parseAnnotation e >>= modify . setMeta "abstract"
375+ "keywords" -> modify (setMeta "keywords" (map (MetaString . trim) $ splitOn "," $ strContent e))
376+ "date" -> modify (setMeta "date" (text $ strContent e))
377+ "coverpage" -> parseCoverPage e
378+ "lang" -> pure ()
379+ "src-lang" -> pure ()
380+ "translator" -> pure ()
381+ "sequence" -> pure ()
382+ name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in title-info.")
383+
384+parseCoverPage :: PandocMonad m => Element -> FB2 m ()
385+parseCoverPage e =
386+ case findChild (QName "image" (Just "http://www.gribuser.ru/xml/fictionbook/2.0") Nothing) e of
387+ Just img -> case href of
388+ Just src -> modify (setMeta "cover-image" (MetaString $ removeHash src))
389+ Nothing -> pure ()
390+ where href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) img
391+ Nothing -> pure ()
392+
393+-- | Parse @inlineImageType@ element
394+parseInlineImageElement :: PandocMonad m
395+ => Element
396+ -> FB2 m Inlines
397+parseInlineImageElement e =
398+ case href of
399+ Just src -> pure $ imageWith ("", [], []) (removeHash src) "" alt
400+ Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: inline image without href."
401+ where alt = maybe mempty str $ findAttr (QName "alt" Nothing Nothing) e
402+ href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e