svitak/app/EpubParser.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
-- The sole BookInfo instance lives here rather than in Types (which must not
-- depend on the parser); the orphan warning is expected.
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Turns a @.epub@ file into a 'BookStructure' (cheap) plus on-demand
-- 'Chapter' rendering.
--
--   1. 'openEpub'       — unzip, locate the OPF, parse metadata\/manifest\/version
--   2. 'loadStructure'  — resolve the spine (reading order) and the TOC tree
--   3. 'renderChapter'  — read one chapter and inline its images, when visited
module EpubParser
  ( EpubEnv (..),
    openEpub,
    getOpfPath,
  )
where

import Codec.Archive.Zip (Archive, Entry, filesInArchive, findEntryByPath, fromEntry, toArchive)
import qualified Codec.Epub.Data.Manifest as DMan
import qualified Codec.Epub.Data.Metadata as DMeta
import Codec.Epub.Data.Package (Package (..))
import qualified Codec.Epub.Data.Spine as DSpin
import Codec.Epub.Parse (getManifest, getMetadata, getPackage)
import qualified Codec.Epub.Parse as EParse
import Control.Applicative ((<|>))
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Reader (ask, runReaderT)
import Control.Monad.Trans (lift)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as B
import Data.List (find, isSuffixOf)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import System.FilePath (joinPath, splitDirectories, takeDirectory, (</>))
import Text.HTML.Scalpel (Scraper, anySelector, attr, chroots, innerHTML, scrapeStringLike)
import Types
  ( BookInfo (..),
    BookStructure (..),
    Chapter (..),
    ChapterIndex (..),
    ChapterRef (..),
    EpubAction,
    EpubEnv (..),
    InternalPath (..),
    TocEntry (..),
    Html(..),
    PlainText(..)
  )
import Navigation (RawToc (..), guideToc, navDocHref, navToc, ncxToc)

-- | The UI talks to a book only through this interface, so it never has to
-- know it's dealing with an EPUB specifically.
instance BookInfo EpubEnv where
  bookTitle env =
    fromMaybe "Unknown Title" $
      T.pack . DMeta.titleText <$> listToMaybe (DMeta.metaTitles (eMetadata env))

  bookAuthors env = map (T.pack . DMeta.creatorText) (DMeta.metaCreators (eMetadata env))

  bookFilePath = bookPath

  loadStructure env = runExceptT (runReaderT buildStructure env)

  renderChapter env ref = runExceptT (runReaderT (renderRef ref) env)

  chapterText env ref = runExceptT (runReaderT (readPText ref) env)
--------------------------------------------------------------------------------
-- Opening the archive
--------------------------------------------------------------------------------

-- | Read the @.epub@ off disk and gather everything the parser needs. Returns
-- @Left@ with a human-readable reason on any failure.
openEpub :: FilePath -> IO (Either String EpubEnv)
openEpub path = do
  arch <- toArchive <$> B.readFile path
  case getOpfPath arch >>= \opf -> (,) opf <$> findEntryByPath opf arch of
    Nothing -> pure (Left "Could not find the OPF package document")
    Just (opfPath, entry) -> do
      let xml = T.unpack (decodeEntry entry)
      meta <- runExceptT (getMetadata xml)
      man <- runExceptT (getManifest xml)
      ver <- runExceptT (detectVersion xml)
      pure $ case (meta, man, ver) of
        (Left err, _, _) -> Left ("Metadata parse error: " ++ err)
        (_, Left err, _) -> Left ("Manifest parse error: " ++ err)
        (_, _, Left err) -> Left ("Version parse error: " ++ err)
        (Right m, Right mn, Right v) ->
          Right
            EpubEnv
              { archive = arch,
                opfXml = xml,
                baseDir = takeDirectory opfPath,
                bookPath = path,
                eMetadata = m,
                eManifest = mn,
                eVersion = T.pack v
              }

-- | Locate the OPF. Normally it's announced in @META-INF/container.xml@; if
-- that's missing or malformed, fall back to scanning the archive for a @.opf@.
getOpfPath :: Archive -> Maybe FilePath
getOpfPath arch = fromContainer <|> scanArchive
  where
    fromContainer = do
      entry <- findEntryByPath "META-INF/container.xml" arch
      scrapeStringLike (decodeEntry entry) (T.unpack <$> attr "full-path" "rootfile")
    scanArchive = find (".opf" `isSuffixOf`) (filesInArchive arch)

detectVersion :: String -> ExceptT String IO String
detectVersion = fmap pkgVersion . getPackage

--------------------------------------------------------------------------------
-- Structure (spine + table of contents)
--------------------------------------------------------------------------------

-- | Resolve the reading order and the TOC tree without rendering any bodies.
-- Spine items whose manifest entry is missing are skipped rather than aborting
-- the whole load.
buildStructure :: EpubAction BookStructure
buildStructure = do
  env <- ask
  let DMan.Manifest items = eManifest env
      hrefOf ident = DMan.mfiHref <$> find ((== ident) . DMan.mfiId) items

  DSpin.Spine tocId refs <- lift (EParse.getSpine (opfXml env))
  toc <- buildToc hrefOf tocId

  let titles = M.fromListWith (\_new old -> old) [(tocTarget t, tocLabel t) | t <- flattenToc toc]
      paths = mapMaybe (fmap (InternalPath . toFullPath env) . hrefOf . DSpin.siIdRef) refs
      titleFor path n = M.findWithDefault ("Chapter " <> T.pack (show (n + 1))) path titles
      chapterRefs =
        [ ChapterRef path (titleFor path n) (ChapterIndex n)
          | (path, n) <- zip paths [0 ..]
        ]
  pure (BookStructure chapterRefs toc)

-- | Build the TOC tree, trying each source in order of richness:
-- EPUB 3 nav document, then EPUB 2 NCX, then the EPUB 2 @\<guide\>@.
buildToc :: (String -> Maybe FilePath) -> String -> EpubAction [TocEntry]
buildToc hrefOf tocId = do
  env <- ask
  let fromDoc mhref scraper = case mhref of
        Nothing -> pure []
        Just href -> readTocDoc (toFullPath env href) scraper
  nav <- fromDoc (navDocHref (opfXml env)) navToc
  ncx <- fromDoc (hrefOf tocId) ncxToc
  let guide = resolveRaws (baseDir env) (fromMaybe [] (scrapeStringLike (T.pack (opfXml env)) guideToc))
  pure (firstNonEmpty [nav, ncx, guide])

-- | Read a TOC document and resolve its entries' hrefs against its own
-- location.
readTocDoc :: FilePath -> Scraper T.Text [RawToc] -> EpubAction [TocEntry]
readTocDoc docPath scraper = do
  env <- ask
  pure $ case findEntry env docPath of
    Nothing -> []
    Just entry -> resolveRaws (takeDirectory docPath) (fromMaybe [] (scrapeStringLike (decodeEntry entry) scraper))

-- | Resolve raw (document-relative) hrefs into full archive paths, splitting
-- off any @#fragment@.
resolveRaws :: FilePath -> [RawToc] -> [TocEntry]
resolveRaws dir = map go
  where
    go (RawToc label href kids) =
      let (path, frag) = breakFragment href
       in TocEntry label (InternalPath (resolveZipPath (dir </> path))) frag (resolveRaws dir kids)

flattenToc :: [TocEntry] -> [TocEntry]
flattenToc = concatMap (\t -> t : flattenToc (tocChildren t))

--------------------------------------------------------------------------------
-- Rendering a single chapter
--------------------------------------------------------------------------------

-- | Read a chapter file and render its @\<body\>@ to self-contained HTML.
renderRef :: ChapterRef -> EpubAction Chapter
renderRef ref = do
  env <- ask
  let InternalPath p = refPath ref
  pure $ case findEntry env p of
    Nothing -> Chapter (refPath ref) (refTitle ref) (Html "") (refIndex ref)
    Just entry ->
      let withImages = embedImages env (takeDirectory p) (decodeEntry entry)
          body = fromMaybe "" (scrapeStringLike withImages bodyScraper)
       in Chapter (refPath ref) (refTitle ref) (Html body) (refIndex ref)

stripTags :: T.Text -> T.Text
stripTags = T.unwords . T.words . go
  where
    go s = case T.break (== '<') s of
      (before, rest)
        | T.null rest -> before
        | otherwise -> before <> " " <> go (T.drop 1 (T.dropWhile (/= '>') rest))

-- | Read a chapter file and render its @\<body\>@ to plaintext, excluding
-- any tags.
readPText :: ChapterRef -> EpubAction PlainText
readPText ref = do
  env <- ask
  let InternalPath p = refPath ref
  pure $ case findEntry env p of
    Nothing -> PlainText ""
    Just entry ->
      PlainText $ stripTags $ fromMaybe "" (scrapeStringLike (decodeEntry entry) bodyScraper)

-- | Grab the contents of @\<body\>@, falling back to the whole document.
bodyScraper :: Scraper T.Text T.Text
bodyScraper = innerHTML "body" <|> innerHTML anySelector

--------------------------------------------------------------------------------
-- Inlining images
--------------------------------------------------------------------------------

-- | Inline images by rewriting each distinct @<img>@ @src@ URL to a base64
-- @data:@ URI, so the rendered HTML is self-contained. We replace the URL
-- string itself (not the whole tag) because scalpel re-serialises tags — e.g.
-- @<img .../>@ becomes @<img ...></img>@ — which would never match the source
-- text. Image @src@s are relative to the chapter file, hence @chapterDir@.
embedImages :: EpubEnv -> FilePath -> T.Text -> T.Text
embedImages env chapterDir content =
  foldr embed content (distinct (fromMaybe [] (scrapeStringLike content imgSrcs)))
  where
    imgSrcs = chroots "img" (attr "src" anySelector) :: Scraper T.Text [T.Text]
    embed src acc = T.replace src (dataUri env chapterDir src) acc
    distinct = M.keys . M.fromList . map (\s -> (s, ()))

-- | Turn an image href into a @data:<mime>;base64,<...>@ URI, or leave it
-- untouched if the file isn't in the archive.
dataUri :: EpubEnv -> FilePath -> T.Text -> T.Text
dataUri env chapterDir src =
  case findEntryByPath path (archive env) of
    Nothing -> src
    Just entry ->
      let b64 = TE.decodeUtf8 (B64.encode (B.toStrict (fromEntry entry)))
       in "data:" <> mimeFor env path <> ";base64," <> b64
  where
    path = resolveZipPath (chapterDir </> T.unpack src)

-- | An entry's declared media type, looked up in the manifest by full path.
mimeFor :: EpubEnv -> FilePath -> T.Text
mimeFor env fullPath =
  case find ((== fullPath) . toFullPath env . DMan.mfiHref) items of
    Just item -> T.pack (DMan.mfiMediaType item)
    Nothing -> "image/jpeg"
  where
    DMan.Manifest items = eManifest env

--------------------------------------------------------------------------------
-- Paths, decoding, small helpers
--------------------------------------------------------------------------------

findEntry :: EpubEnv -> FilePath -> Maybe Entry
findEntry env path = findEntryByPath path (archive env)

-- | Resolve a manifest/TOC href (relative to the OPF) to a full archive path.
toFullPath :: EpubEnv -> FilePath -> FilePath
toFullPath env href = resolveZipPath (baseDir env </> href)

-- | Normalise an already-joined path: drop any @#fragment@ and collapse @.@
-- and @..@ segments. 'System.FilePath.normalise' does /not/ collapse @..@,
-- which is why relative hrefs like @../Images/p1.jpg@ would otherwise miss.
resolveZipPath :: FilePath -> FilePath
resolveZipPath raw =
  joinPath (reverse (foldl step [] (splitDirectories (fst (breakFragment raw)))))
  where
    step acc "." = acc
    step (_ : rest) ".." = rest
    step acc ".." = acc
    step acc seg = seg : acc

-- | Split an href into its path and (un-@#@-prefixed) fragment.
breakFragment :: FilePath -> (FilePath, T.Text)
breakFragment href = (path, T.pack (drop 1 frag))
  where
    (path, frag) = break (== '#') href

firstNonEmpty :: [[a]] -> [a]
firstNonEmpty = fromMaybe [] . find (not . null)

-- | Decode a zip entry to text, honouring a BOM and tolerating non-UTF-8 bytes
-- (falling back to Latin-1) rather than throwing.
decodeEntry :: Entry -> T.Text
decodeEntry = decodeBytes . B.toStrict . fromEntry

decodeBytes :: BS.ByteString -> T.Text
decodeBytes bs
  | "\xEF\xBB\xBF" `BS.isPrefixOf` bs = decodeBytes (BS.drop 3 bs)
  | "\xFF\xFE" `BS.isPrefixOf` bs = TE.decodeUtf16LE (BS.drop 2 bs)
  | "\xFE\xFF" `BS.isPrefixOf` bs = TE.decodeUtf16BE (BS.drop 2 bs)
  | otherwise = either (const (TE.decodeLatin1 bs)) id (TE.decodeUtf8' bs)