EPUB writer: fixed EPUB OCF structure.

The structure of the EPUBs was messed up, and #3720 was
improperly implemented.  This commit fixes things.

1 files changed, 82 insertions, 65 deletions

diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs
index 0dcef1d63..23df046d0 100644
--- a/src/Text/Pandoc/Writers/EPUB.hs
+++ b/src/Text/Pandoc/Writers/EPUB.hs
@@ -48,7 +48,7 @@ import qualified Data.Set as Set
 import qualified Data.Text as TS
 import qualified Data.Text.Lazy as TL
 import Network.HTTP (urlEncode)
-import System.FilePath (takeExtension, takeFileName)
+import System.FilePath (takeExtension, takeFileName, makeRelative)
 import Text.HTML.TagSoup (Tag (TagOpen), fromAttrib, parseTags)
 import Text.Pandoc.Builder (fromList, setMeta)
 import Text.Pandoc.Class (PandocMonad, report)
@@ -81,6 +81,7 @@ data Chapter = Chapter (Maybe [Int]) [Block]
 
 data EPUBState = EPUBState {
         stMediaPaths  :: [(FilePath, (FilePath, Maybe Entry))]
+      , stEpubSubdir  :: String
       }
 
 type E m = StateT EPUBState m
@@ -149,6 +150,20 @@ removeNote :: Inline -> Inline
 removeNote (Note _) = Str ""
 removeNote x        = x
 
+mkEntry :: PandocMonad m => FilePath -> B.ByteString -> E m Entry
+mkEntry path content = do
+  epubSubdir <- gets stEpubSubdir
+  let addEpubSubdir :: Entry -> Entry
+      addEpubSubdir e = e{ eRelativePath =
+          (if null epubSubdir
+              then ""
+              else epubSubdir ++ "/") ++ eRelativePath e }
+  epochtime <- floor <$> lift P.getPOSIXTime
+  return $
+       (if path == "mimetype" || "META-INF" `isPrefixOf` path
+           then id
+           else addEpubSubdir) $ toEntry path epochtime content
+
 getEPUBMetadata :: PandocMonad m => WriterOptions -> Meta -> E m EPUBMetadata
 getEPUBMetadata opts meta = do
   let md = metadataFromMeta opts meta
@@ -366,11 +381,13 @@ writeEPUB :: PandocMonad m
           -> WriterOptions  -- ^ Writer options
           -> Pandoc         -- ^ Document to convert
           -> m B.ByteString
-writeEPUB epubVersion opts doc =
-  let initState = EPUBState { stMediaPaths = [] }
-  in
-    evalStateT (pandocToEPUB epubVersion opts doc)
-      initState
+writeEPUB epubVersion opts doc = do
+  let epubSubdir = writerEpubSubdirectory opts
+  -- sanity check on epubSubdir
+  unless (all (\c -> isAscii c && isAlphaNum c) epubSubdir) $
+    throwError $ PandocEpubSubdirectoryError epubSubdir
+  let initState = EPUBState { stMediaPaths = [], stEpubSubdir = epubSubdir }
+  evalStateT (pandocToEPUB epubVersion opts doc) initState
 
 pandocToEPUB :: PandocMonad m
              => EPUBVersion
@@ -378,27 +395,18 @@ pandocToEPUB :: PandocMonad m
              -> Pandoc
              -> E m B.ByteString
 pandocToEPUB version opts doc@(Pandoc meta _) = do
-  let epubSubdir = writerEpubSubdirectory opts
-  -- sanity check on epubSubdir
-  unless (all (\c -> isAscii c && isAlphaNum c) epubSubdir) $
-    throwError $ PandocEpubSubdirectoryError epubSubdir
-  let inSubdir f = if null epubSubdir
-                      then f
-                      else epubSubdir ++ "/" ++ f
-
+  epubSubdir <- gets stEpubSubdir
   let epub3 = version == EPUB3
   let writeHtml o = fmap (UTF8.fromTextLazy . TL.fromStrict) .
                       writeHtmlStringForEPUB version o
-  epochtime <- floor <$> lift P.getPOSIXTime
   metadata <- getEPUBMetadata opts meta
-  let mkEntry path content = toEntry path epochtime content
 
   -- stylesheet
   stylesheets <- case epubStylesheets metadata of
                       [] -> (\x -> [B.fromChunks [x]]) <$>
                              P.readDataFile "epub.css"
                       fs -> mapM P.readFileLazy fs
-  let stylesheetEntries = zipWith
+  stylesheetEntries <- zipWithM
         (\bs n -> mkEntry ("styles/stylesheet" ++ show n ++ ".css") bs)
         stylesheets [(1 :: Int)..]
 
@@ -406,10 +414,10 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
              : [(x,y) | (x,y) <- writerVariables opts, x /= "css"]
 
   let cssvars useprefix = map (\e -> ("css",
-                               (if useprefix && not (null epubSubdir)
+                               (if useprefix
                                    then "../"
                                    else "")
-                               ++ eRelativePath e))
+                               ++ makeRelative epubSubdir (eRelativePath e)))
                           stylesheetEntries
 
   let opts' = opts{ writerEmailObfuscation = NoObfuscation
@@ -430,18 +438,21 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
                        cpContent <- lift $ writeHtml
                             opts'{ writerVariables =
                                     ("coverpage","true"):
-                                     cssvars False ++ vars }
-                            (Pandoc meta [RawBlock (Format "html") $ "<div id=\"cover-image\">\n<img src=\"" ++ coverImage ++ "\" alt=\"cover image\" />\n</div>"])
+                                     cssvars True ++ vars }
+                            (Pandoc meta [RawBlock (Format "html") $ "<div id=\"cover-image\">\n<img src=\"../media/" ++ coverImage ++ "\" alt=\"cover image\" />\n</div>"])
                        imgContent <- lift $ P.readFileLazy img
-                       return ( [mkEntry "cover.xhtml" cpContent]
-                              , [mkEntry coverImage imgContent] )
+                       coverEntry <- mkEntry "text/cover.xhtml" cpContent
+                       coverImageEntry <- mkEntry ("media/" ++ coverImage)
+                                             imgContent
+                       return ( [ coverEntry ]
+                              , [ coverImageEntry ] )
 
   -- title page
   tpContent <- lift $ writeHtml opts'{
                                   writerVariables = ("titlepage","true"):
                                   cssvars True ++ vars }
                                (Pandoc meta [])
-  let tpEntry = mkEntry (inSubdir "title_page.xhtml") tpContent
+  tpEntry <- mkEntry "text/title_page.xhtml" tpContent
 
   -- handle pictures
   -- mediaRef <- P.newIORef []
@@ -454,7 +465,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
         when (null xs) $
           report $ CouldNotFetchResource f "glob did not match any font files"
         return xs
-  let mkFontEntry f = mkEntry ("fonts/" ++ takeFileName f) <$>
+  let mkFontEntry f = mkEntry ("fonts/" ++ takeFileName f) =<<
                         lift (P.readFileLazy f)
   fontFiles <- concat <$> mapM matchingGlob (writerEpubFonts opts')
   fontEntries <- mapM mkFontEntry fontFiles
@@ -540,7 +551,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
                  chapters'
 
   let chapToEntry num (Chapter mbnum bs) =
-       mkEntry (inSubdir (showChapter num)) <$>
+        mkEntry ("text/" ++ showChapter num) =<<
         writeHtml opts'{ writerNumberOffset = fromMaybe [] mbnum
                        , writerVariables = cssvars True ++ vars }
                  (case bs of
@@ -550,7 +561,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
                                  nullMeta) bs
                      _                   -> Pandoc nullMeta bs)
 
-  chapterEntries <- lift $ zipWithM chapToEntry [1..] chapters
+  chapterEntries <- zipWithM chapToEntry [1..] chapters
 
   -- incredibly inefficient (TODO):
   let containsMathML ent = epub3 &&
@@ -563,24 +574,34 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
 
   -- contents.opf
   let chapterNode ent = unode "item" !
-                           ([("id", toId $ eRelativePath ent),
-                             ("href", eRelativePath ent),
+                           ([("id", toId $ makeRelative epubSubdir
+                                         $ eRelativePath ent),
+                             ("href", makeRelative epubSubdir
+                                      $ eRelativePath ent),
                              ("media-type", "application/xhtml+xml")]
                             ++ case props ent of
                                     [] -> []
                                     xs -> [("properties", unwords xs)])
                         $ ()
+
   let chapterRefNode ent = unode "itemref" !
-                             [("idref", toId $ eRelativePath ent)] $ ()
+                             [("idref", toId $ makeRelative epubSubdir
+                                             $ eRelativePath ent)] $ ()
   let pictureNode ent = unode "item" !
-                           [("id", toId $ eRelativePath ent),
-                            ("href", eRelativePath ent),
-                            ("media-type", fromMaybe "application/octet-stream"
+                           [("id", toId $ makeRelative epubSubdir
+                                        $ eRelativePath ent),
+                            ("href", makeRelative epubSubdir
+                                     $ eRelativePath ent),
+                            ("media-type",
+                               fromMaybe "application/octet-stream"
                                $ mediaTypeOf $ eRelativePath ent)] $ ()
   let fontNode ent = unode "item" !
-                           [("id", toId $ eRelativePath ent),
-                            ("href", eRelativePath ent),
-                            ("media-type", fromMaybe "" $ getMimeType $ eRelativePath ent)] $ ()
+                           [("id", toId $ makeRelative epubSubdir
+                                        $ eRelativePath ent),
+                            ("href", makeRelative epubSubdir
+                                     $ eRelativePath ent),
+                            ("media-type", fromMaybe "" $
+                                  getMimeType $ eRelativePath ent)] $ ()
   let plainTitle = case docTitle' meta of
                         [] -> case epubTitle metadata of
                                    []    -> "UNTITLED"
@@ -613,7 +634,9 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
              ] ++
              [ unode "item" ! [("id","style"), ("href",fp)
                               ,("media-type","text/css")] $ () |
-                          fp <- map eRelativePath stylesheetEntries ] ++
+                             fp <- map
+                               (makeRelative epubSubdir . eRelativePath)
+                               stylesheetEntries ] ++
              map chapterNode (cpgEntry ++ (tpEntry : chapterEntries)) ++
              (case cpicEntry of
                     []    -> []
@@ -648,7 +671,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
                | isJust (epubCoverImage metadata)
              ]
           ]
-  let contentsEntry = mkEntry "content.opf" contentsData
+  contentsEntry <- mkEntry "content.opf" contentsData
 
   -- toc.ncx
   let secs = hierarchicalize blocks'
@@ -681,12 +704,12 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
       navMapFormatter n tit src subs = unode "navPoint" !
                [("id", "navPoint-" ++ show n)] $
                   [ unode "navLabel" $ unode "text" $ stringify tit
-                  , unode "content" ! [("src", inSubdir src)] $ ()
+                  , unode "content" ! [("src", "text/" ++ src)] $ ()
                   ] ++ subs
 
   let tpNode = unode "navPoint" !  [("id", "navPoint-0")] $
                   [ unode "navLabel" $ unode "text" (stringify $ docTitle' meta)
-                  , unode "content" ! [("src", inSubdir "title_page.xhtml")]
+                  , unode "content" ! [("src", "text/title_page.xhtml")]
                   $ () ]
 
   navMap <- lift $ evalStateT (mapM (navPointNode navMapFormatter) secs) 1
@@ -710,13 +733,13 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
           , unode "navMap" $
               tpNode : navMap
           ]
-  let tocEntry = mkEntry "toc.ncx" tocData
+  tocEntry <- mkEntry "toc.ncx" tocData
 
   let navXhtmlFormatter :: Int -> [Inline] -> String -> [Element] -> Element
       navXhtmlFormatter n tit src subs = unode "li" !
                                        [("id", "toc-li-" ++ show n)] $
                                             (unode "a" !
-                                                [("href", inSubdir src)]
+                                                [("href", "text/" ++ src)]
                                              $ titElements)
                                             : case subs of
                                                  []    -> []
@@ -766,36 +789,37 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do
             (Pandoc (setMeta "title"
                      (walk removeNote $ fromList $ docTitle' meta) nullMeta)
                (navBlocks ++ landmarks))
-  let navEntry = mkEntry "nav.xhtml" navData
+  navEntry <- mkEntry "nav.xhtml" navData
 
   -- mimetype
-  let mimetypeEntry = mkEntry "mimetype" $ UTF8.fromStringLazy "application/epub+zip"
+  mimetypeEntry <- mkEntry "mimetype" $
+                        UTF8.fromStringLazy "application/epub+zip"
 
   -- container.xml
   let containerData = UTF8.fromStringLazy $ ppTopElement $
        unode "container" ! [("version","1.0")
               ,("xmlns","urn:oasis:names:tc:opendocument:xmlns:container")] $
          unode "rootfiles" $
-           unode "rootfile" ! [("full-path", inSubdir "content.opf")
+           unode "rootfile" ! [("full-path",
+                    (if null epubSubdir
+                        then ""
+                        else epubSubdir ++ "/") ++ "content.opf")
                ,("media-type","application/oebps-package+xml")] $ ()
-  let containerEntry = mkEntry "META-INF/container.xml" containerData
+  containerEntry <- mkEntry "META-INF/container.xml" containerData
 
   -- com.apple.ibooks.display-options.xml
   let apple = UTF8.fromStringLazy $ ppTopElement $
         unode "display_options" $
           unode "platform" ! [("name","*")] $
             unode "option" ! [("name","specified-fonts")] $ "true"
-  let appleEntry = mkEntry "META-INF/com.apple.ibooks.display-options.xml" apple
+  appleEntry <- mkEntry "META-INF/com.apple.ibooks.display-options.xml" apple
 
-  let addEpubSubdir :: Entry -> Entry
-      addEpubSubdir e = e{ eRelativePath = inSubdir (eRelativePath e) }
   -- construct archive
   let archive = foldr addEntryToArchive emptyArchive $
-                 [mimetypeEntry, containerEntry, appleEntry] ++
-                 map addEpubSubdir
-                 (tpEntry : contentsEntry : tocEntry : navEntry :
-                  (stylesheetEntries ++ picEntries ++ cpicEntry ++
-                   cpgEntry ++ chapterEntries ++ fontEntries))
+                 [mimetypeEntry, containerEntry, appleEntry,
+                  contentsEntry, tocEntry, navEntry, tpEntry] ++
+                  stylesheetEntries ++ picEntries ++ cpicEntry ++
+                  cpgEntry ++ chapterEntries ++ fontEntries
   return $ fromArchive archive
 
 metadataElement :: EPUBVersion -> EPUBMetadata -> UTCTime -> Element
@@ -936,8 +960,7 @@ modifyMediaRef oldsrc = do
                let new = "media/file" ++ show (length media) ++
                           fromMaybe (takeExtension (takeWhile (/='?') oldsrc))
                           (('.':) <$> (mbMime >>= extensionFromMimeType))
-               epochtime <- floor `fmap` lift P.getPOSIXTime
-               let entry = toEntry new epochtime (B.fromChunks . (:[]) $ img)
+               entry <- mkEntry new (B.fromChunks . (:[]) $ img)
                modify $ \st -> st{ stMediaPaths =
                             (oldsrc, (new, Just entry)):media}
                return new)
@@ -959,21 +982,15 @@ transformInline  :: PandocMonad m
                  => WriterOptions
                  -> Inline
                  -> E m Inline
-transformInline opts (Image attr lab (src,tit)) = do
+transformInline _opts (Image attr lab (src,tit)) = do
     newsrc <- modifyMediaRef src
-    let pref = if null (writerEpubSubdirectory opts)
-                  then ""
-                  else "../"
-    return $ Image attr lab (pref ++ newsrc, tit)
+    return $ Image attr lab ("../" ++ newsrc, tit)
 transformInline opts (x@(Math t m))
   | WebTeX url <- writerHTMLMathMethod opts = do
     newsrc <- modifyMediaRef (url ++ urlEncode m)
     let mathclass = if t == DisplayMath then "display" else "inline"
-    let pref = if null (writerEpubSubdirectory opts)
-                  then ""
-                  else "../"
     return $ Span ("",["math",mathclass],[])
-                [Image nullAttr [x] (pref ++ newsrc, "")]
+                [Image nullAttr [x] ("../" ++ newsrc, "")]
 transformInline _opts (RawInline fmt raw)
   | fmt == Format "html" = do
   let tags = parseTags raw