@@ -22,7 +22,9 @@ import qualified Text.Pandoc.Builder as B
2222import Codec.Archive.Zip ( Archive (..), toArchive, fromEntry
2323 , findEntryByPath, Entry)
2424import qualified Data.ByteString.Lazy as BL (ByteString)
25−import System.FilePath (takeFileName, (</>), dropFileName, normalise)
25+import System.FilePath ( takeFileName, (</>), dropFileName, normalise
26+ , joinPath, dropFileName, splitDirectories
27+ , splitFileName )
2628import qualified Text.Pandoc.UTF8 as UTF8 (toStringLazy)
2729import Control.Applicative ((<$>))
2830import Control.Monad (guard, liftM, when)
@@ -48,13 +50,12 @@ runEPUB = either error id . runExcept
4850-- Note that internal reference are aggresively normalised so that all ids
4951-- are of the form "filename#id"
5052--
51−-- For now all paths are stripped from images
5253archiveToEPUB :: (MonadError String m) => ReaderOptions -> Archive -> m (Pandoc, MediaBag)
5354archiveToEPUB os archive = do
5455 (root, content) <- getManifest archive
5556 meta <- parseMeta content
5657 (cover, items) <- parseManifest content
57− let coverDoc = fromMaybe mempty (imageToPandoc . takeFileName <$> cover)
58+ let coverDoc = fromMaybe mempty (imageToPandoc <$> cover)
5859 spine <- parseSpine items content
5960 let escapedSpine = map (escapeURI . takeFileName . fst) spine
6061 Pandoc _ bs <-
@@ -68,16 +69,19 @@ archiveToEPUB os archive = do
6869 os' = os {readerExtensions = foldr S.insert rs [Ext_epub_html_exts, Ext_raw_html]}
6970 os'' = os' {readerParseRaw = True}
7071 parseSpineElem :: MonadError String m => FilePath -> (FilePath, MIME) -> m Pandoc
71− parseSpineElem r (path, mime) = do
72+ parseSpineElem (normalise -> r) (normalise -> path, mime) = do
7273 when (readerTrace os) (traceM path)
73− doc <- mimeToReader mime (normalise (r </> path))
74+ doc <- mimeToReader mime r path
7475 let docSpan = B.doc $ B.para $ B.spanWith (takeFileName path, [], []) mempty
75− return $ docSpan <> fixInternalReferences (takeFileName path) doc
76− mimeToReader :: MonadError String m => MIME -> FilePath -> m Pandoc
77− mimeToReader "application/xhtml+xml" path = do
78− fname <- findEntryByPathE path archive
79− return $ readHtml os'' . UTF8.toStringLazy $ fromEntry fname
80− mimeToReader s path
76+ return $ docSpan <> doc
77+ mimeToReader :: MonadError String m => MIME -> FilePath -> FilePath -> m Pandoc
78+ mimeToReader "application/xhtml+xml" r path = do
79+ fname <- findEntryByPathE (r </> path) archive
80+ return $ fixInternalReferences (r </> path) .
81+ readHtml os'' .
82+ UTF8.toStringLazy $
83+ fromEntry fname
84+ mimeToReader s _ path
8185 | s `elem` imageMimes = return $ imageToPandoc path
8286 | otherwise = return $ mempty
8387
@@ -86,18 +90,34 @@ fetchImages :: [(FilePath, MIME)]
8690 -> Archive
8791 -> Pandoc
8892 -> MediaBag
89−fetchImages mimes root a (query iq -> links) =
93+fetchImages mimes root arc (query iq -> links) =
9094 foldr (uncurry3 insertMedia) mempty
9195 (mapMaybe getEntry links)
9296 where
93− getEntry l = let mediaPos = normalise (root </> l) in
94− (l , lookup mediaPos mimes, ) . fromEntry
95− <$> findEntryByPath mediaPos a
97+ getEntry (normalise -> l) =
98+ let mediaPos = normalise (root </> l) in
99+ (l , lookup mediaPos mimes, ) . fromEntry
100+ <$> findEntryByPath mediaPos arc
96101
97102iq :: Inline -> [FilePath]
98103iq (Image _ (url, _)) = [url]
99104iq _ = []
100105
106+-- Remove relative paths
107+renameImages :: FilePath -> Inline -> Inline
108+renameImages root (Image a (url, b)) = Image a (collapse (root </> url), b)
109+renameImages _ x = x
110+
111+collapse :: FilePath -> FilePath
112+collapse = joinPath . reverse . foldl go [] . splitDirectories
113+ where
114+ go rs "." = rs
115+ go r@(p:rs) ".." = case p of
116+ ".." -> ("..":r)
117+ "/" -> ("..":r)
118+ _ -> rs
119+ go _ "/" = ["/"]
120+ go rs x = x:rs
101121
102122imageToPandoc :: FilePath -> Pandoc
103123imageToPandoc s = B.doc . B.para $ B.image s "" mempty
@@ -168,11 +188,14 @@ getManifest archive = do
168188
169189-- Fixup
170190
171−fixInternalReferences :: String -> Pandoc -> Pandoc
172−fixInternalReferences s =
173− (walk normalisePath) . (walk $ fixBlockIRs s') . (walk $ fixInlineIRs s')
191+fixInternalReferences :: FilePath -> Pandoc -> Pandoc
192+fixInternalReferences pathToFile =
193+ (walk $ renameImages root)
194+ . (walk normalisePath)
195+ . (walk $ fixBlockIRs filename)
196+ . (walk $ fixInlineIRs filename)
174197 where
175− s' = escapeURI s
198+ (root, escapeURI -> filename) = splitFileName pathToFile
176199
177200fixInlineIRs :: String -> Inline -> Inline
178201fixInlineIRs s (Span as v) =
@@ -227,12 +250,12 @@ foldM' f z (x:xs) = do
227250 z' <- f z x
228251 z' `deepseq` foldM' f z' xs
229252
230−traceM :: Monad m => String -> m ()
231−traceM = flip trace (return ())
232−
233253uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
234254uncurry3 f (a, b, c) = f a b c
235255
256+traceM :: Monad m => String -> m ()
257+traceM = flip trace (return ())
258+
236259-- Utility
237260
238261stripNamespace :: QName -> String
@@ -270,4 +293,3 @@ findElementE e x = mkE ("Unable to find element: " ++ show e) $ findElement e x
270293
271294mkE :: MonadError String m => String -> Maybe a -> m a
272295mkE s = maybe (throwError s) return
273−