@@ -0,0 +1,248 @@
1+{-# LANGUAGE
2+ ViewPatterns
3+ , StandaloneDeriving
4+ , FlexibleContexts #-}
5+
6+module Text.Pandoc.Readers.EPUB
7+ (readEPUB)
8+ where
9+
10+import Text.XML.Light
11+import Text.Pandoc.Definition hiding (Attr)
12+import Text.Pandoc.Walk (walk)
13+import Text.Pandoc.Generic(bottomUp)
14+import Text.Pandoc.Readers.HTML (readHtml)
15+import Text.Pandoc.Options (ReaderOptions(..), readerExtensions, Extension(..) )
16+import Text.Pandoc.Shared (escapeURI)
17+import Text.Pandoc.Compat.Except (MonadError, throwError, runExcept, Except)
18+import qualified Text.Pandoc.Builder as B
19+import Codec.Archive.Zip ( Archive (..), toArchive, fromEntry
20+ , findEntryByPath, Entry)
21+import qualified Data.ByteString.Lazy as BL (ByteString)
22+import System.FilePath (takeFileName, (</>), dropFileName)
23+import qualified Text.Pandoc.UTF8 as UTF8 (toStringLazy)
24+import Control.Applicative ((<$>))
25+import Control.Monad (guard, liftM)
26+import Data.Monoid (mempty, (<>))
27+import Data.List (isPrefixOf, isInfixOf)
28+import Data.Maybe (mapMaybe, fromMaybe)
29+import qualified Data.Map as M (Map, lookup, fromList)
30+import qualified Data.Set as S (insert)
31+import Control.DeepSeq.Generics (deepseq, NFData)
32+
33+type MIME = String
34+
35+type Items = M.Map String (FilePath, MIME)
36+
37+readEPUB :: ReaderOptions -> BL.ByteString -> Pandoc
38+readEPUB opts bytes = runEPUB (archiveToEPUB opts $ toArchive bytes)
39+
40+runEPUB :: Except String a -> a
41+runEPUB = either error id . runExcept
42+
43+-- Note that internal reference are aggresively normalised so that all ids
44+-- are of the form "filename#id"
45+--
46+-- For now all paths are stripped from images
47+archiveToEPUB :: (MonadError String m) => ReaderOptions -> Archive -> m Pandoc
48+archiveToEPUB os archive = do
49+ (root, content) <- getManifest archive
50+ meta <- parseMeta content
51+ (cover, items) <- parseManifest content
52+ let coverDoc = fromMaybe mempty (imageToPandoc . takeFileName<$> cover)
53+ spine <- parseSpine items content
54+ let escapedSpine = map (escapeURI . takeFileName . fst) spine
55+ --traceShow escapedSpine (return ())
56+ Pandoc _ bs <-
57+ foldM' (\a b -> ((a <>) . bottomUp (prependHash escapedSpine))
58+ `liftM` parseSpineElem root b) mempty spine
59+ return $ coverDoc <> (Pandoc meta bs)
60+ where
61+ rs = readerExtensions os
62+ os' = os {readerExtensions = foldr S.insert rs [Ext_epub_html_exts, Ext_raw_html]}
63+ os'' = os' {readerParseRaw = True}
64+ parseSpineElem :: MonadError String m => FilePath -> (FilePath, MIME) -> m Pandoc
65+ parseSpineElem r (path, mime) = do
66+ --traceShow path (return ())
67+ doc <- mimeToReader mime (if r /= "./" then r </> path else path)
68+ let docSpan = B.doc $ B.para $ B.spanWith (takeFileName path, [], []) mempty
69+ return $ docSpan <> fixInternalReferences (takeFileName path) doc
70+ mimeToReader :: MonadError String m => MIME -> FilePath -> m Pandoc
71+ mimeToReader "application/xhtml+xml" path = do
72+ fname <- findEntryByPathE path archive
73+ return $ readHtml os'' . UTF8.toStringLazy $ fromEntry fname
74+ mimeToReader s path
75+ | s `elem` imageMimes = return $ imageToPandoc path
76+ | otherwise = return $ mempty
77+
78+
79+imageToPandoc :: FilePath -> Pandoc
80+imageToPandoc s = B.doc . B.para $ B.image s "" mempty
81+
82+imageMimes :: [String]
83+imageMimes = ["image/gif", "image/jpeg", "image/png"]
84+
85+type CoverImage = FilePath
86+
87+parseManifest :: (MonadError String m) => Element -> m (Maybe CoverImage, Items)
88+parseManifest content = do
89+ manifest <- findElementE (dfName "manifest") content
90+ let items = findChildren (dfName "item") manifest
91+ r <- mapM parseItem items
92+ let cover = findAttr (emptyName "href") =<< filterChild findCover manifest
93+ return (cover, (M.fromList r))
94+ where
95+ findCover e = maybe False (isInfixOf "cover-image")
96+ (findAttr (emptyName "properties") e)
97+ parseItem e = do
98+ uid <- findAttrE (emptyName "id") e
99+ href <- findAttrE (emptyName "href") e
100+ mime <- findAttrE (emptyName "media-type") e
101+ return (uid, (href, mime))
102+
103+parseSpine :: MonadError String m => Items -> Element -> m [(FilePath, MIME)]
104+parseSpine is e = do
105+ spine <- findElementE (dfName "spine") e
106+ let itemRefs = findChildren (dfName "itemref") spine
107+ mapM (mkE "parseSpine" . (flip M.lookup is)) $ mapMaybe parseItemRef itemRefs
108+ where
109+ parseItemRef ref = do
110+ let linear = maybe True (== "yes") (findAttr (emptyName "linear") ref)
111+ guard linear
112+ findAttr (emptyName "idref") ref
113+
114+parseMeta :: MonadError String m => Element -> m Meta
115+parseMeta content = do
116+ meta <- findElementE (dfName "metadata") content
117+ let dcspace (QName _ (Just "http://purl.org/dc/elements/1.1/") (Just "dc")) = True
118+ dcspace _ = False
119+ let dcs = filterChildrenName dcspace meta
120+ let r = foldr parseMetaItem nullMeta dcs
121+ return r
122+
123+-- http://www.idpf.org/epub/30/spec/epub30-publications.html#sec-metadata-elem
124+parseMetaItem :: Element -> Meta -> Meta
125+parseMetaItem e@(stripNamespace . elName -> field) meta =
126+ B.setMeta (renameMeta field) (B.str $ strContent e) meta
127+
128+renameMeta :: String -> String
129+renameMeta "creator" = "author"
130+renameMeta s = s
131+
132+getManifest :: MonadError String m => Archive -> m (String, Element)
133+getManifest archive = do
134+ metaEntry <- findEntryByPathE ("META-INF" </> "container.xml") archive
135+ docElem <- (parseXMLDocE . UTF8.toStringLazy . fromEntry) metaEntry
136+ let namespaces = mapMaybe attrToNSPair (elAttribs docElem)
137+ ns <- mkE "xmlns not in namespaces" (lookup "xmlns" namespaces)
138+ as <- liftM ((map attrToPair) . elAttribs)
139+ (findElementE (QName "rootfile" (Just ns) Nothing) docElem)
140+ root <- mkE "Root not found" (lookup "full-path" as)
141+ let rootdir = dropFileName root
142+ --mime <- lookup "media-type" as
143+ manifest <- findEntryByPathE root archive
144+ liftM ((,) rootdir) (parseXMLDocE . UTF8.toStringLazy . fromEntry $ manifest)
145+
146+-- Fixup
147+
148+fixInternalReferences :: String -> Pandoc -> Pandoc
149+fixInternalReferences s =
150+ (walk normalisePath) . (walk stripImage) . (walk $ fixBlockIRs s') . (walk $ fixInlineIRs s')
151+ where
152+ s' = escapeURI s
153+
154+fixInlineIRs :: String -> Inline -> Inline
155+fixInlineIRs s (Span as v) =
156+ Span (fixAttrs s as) v
157+fixInlineIRs s (Code as code) =
158+ Code (fixAttrs s as) code
159+fixInlineIRs s (Link t ('#':url, tit)) =
160+ Link t (addHash s url, tit)
161+fixInlineIRs _ v = v
162+
163+normalisePath :: Inline -> Inline
164+normalisePath (Link t (url, tit)) =
165+ let (path, uid) = span (/= '#') url in
166+ Link t (takeFileName path ++ uid, tit)
167+normalisePath s = s
168+
169+prependHash :: [String] -> Inline -> Inline
170+prependHash ps l@(Link is (url, tit))
171+ | or [s `isPrefixOf` url | s <- ps] =
172+ Link is ('#':url, tit)
173+ | otherwise = l
174+prependHash _ i = i
175+
176+fixBlockIRs :: String -> Block -> Block
177+fixBlockIRs s (Div as b) =
178+ Div (fixAttrs s as) b
179+fixBlockIRs s (Header i as b) =
180+ Header i (fixAttrs s as) b
181+fixBlockIRs s (CodeBlock as code) =
182+ CodeBlock (fixAttrs s as) code
183+fixBlockIRs _ b = b
184+
185+fixAttrs :: FilePath -> B.Attr -> B.Attr
186+fixAttrs s (ident, cs, kvs) = (addHash s ident, filter (not . null) cs, removeEPUBAttrs kvs)
187+
188+addHash :: String -> String -> String
189+addHash _ "" = ""
190+addHash s ident = s ++ "#" ++ ident
191+
192+removeEPUBAttrs :: [(String, String)] -> [(String, String)]
193+removeEPUBAttrs kvs = filter (not . isEPUBAttr) kvs
194+
195+isEPUBAttr :: (String, String) -> Bool
196+isEPUBAttr (k, _) = "epub:" `isPrefixOf` k
197+
198+-- Remove relative paths
199+stripImage :: Inline -> Inline
200+stripImage (Image alt (url, tit)) = Image alt (takeFileName url, tit)
201+stripImage i = i
202+
203+
204+-- Utility
205+
206+-- Strict version of foldM
207+foldM' :: (Monad m, NFData a) => (a -> b -> m a) -> a -> [b] -> m a
208+foldM' _ z [] = return z
209+foldM' f z (x:xs) = do
210+ z' <- f z x
211+ z' `deepseq` foldM' f z' xs
212+
213+stripNamespace :: QName -> String
214+stripNamespace (QName v _ _) = v
215+
216+attrToNSPair :: Attr -> Maybe (String, String)
217+attrToNSPair (Attr (QName "xmlns" _ _) val) = Just ("xmlns", val)
218+attrToNSPair _ = Nothing
219+
220+attrToPair :: Attr -> (String, String)
221+attrToPair (Attr (QName name _ _) val) = (name, val)
222+
223+defaultNameSpace :: Maybe String
224+defaultNameSpace = Just "http://www.idpf.org/2007/opf"
225+
226+dfName :: String -> QName
227+dfName s = QName s defaultNameSpace Nothing
228+
229+emptyName :: String -> QName
230+emptyName s = QName s Nothing Nothing
231+
232+-- Convert Maybe interface to Either
233+
234+findAttrE :: MonadError String m => QName -> Element -> m String
235+findAttrE q e = mkE "findAttr" $ findAttr q e
236+
237+findEntryByPathE :: MonadError String m => FilePath -> Archive -> m Entry
238+findEntryByPathE path a = mkE ("No entry on path: " ++ path) $ findEntryByPath path a
239+
240+parseXMLDocE :: MonadError String m => String -> m Element
241+parseXMLDocE doc = mkE "Unable to parse XML doc" $ parseXMLDoc doc
242+
243+findElementE :: MonadError String m => QName -> Element -> m Element
244+findElementE e x = mkE ("Unable to find element: " ++ show e) $ findElement e x
245+
246+mkE :: MonadError String m => String -> Maybe a -> m a
247+mkE s = maybe (throwError s) return
248+