svitak/app/EpubParser.hs

{-# LANGUAGE OverloadedStrings #-}

module EpubParser
  ( EpubAction,
    EpubEnv (..),
    openEpub,
    getOpfPath,
    resolveSpine,
    getChapter,
  )
where

import Codec.Archive.Zip (Archive, findEntryByPath, fromEntry, toArchive)
import qualified Codec.Epub.Data.Manifest as DMan
import qualified Codec.Epub.Data.Spine as DSpin
import Codec.Epub.Parse (getManifest, getMetadata, getSpine)
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (MonadReader (ask), liftIO, runReaderT)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as B
import Data.List (find, foldl')
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import System.FilePath (normalise, takeDirectory, (</>))
import Text.HTML.Scalpel (Scraper, ScraperT, anySelector, attr, chroot, chroots, html, innerHTML, scrapeStringLike, text)
import Types (Chapter (..), EpubAction, EpubEnv (..), InternalPath(..), ChapterIndex(..), BookInfo(..), EpubType(..))
import Navigation (navFinder, lndmkScraper)
import Codec.Epub.Data.Metadata (metaTitles, titleText, titleType, Creator (creatorText), Metadata (metaCreators))

instance BookInfo EpubEnv where
  getTitle env =
    let titles = metaTitles (eMetadata env)
    in case find (\t -> titleType t == Just "main") titles of
      Just t -> T.pack (titleText t)
      Nothing -> if null titles then "Unknown" else T.pack (titleText (head titles))

  getAuthors env =  map (T.pack . creatorText) (metaCreators (eMetadata env))

  getLandmarks env =
      let xmlStr = opfXml env
          maybeNavPath = scrapeStringLike xmlStr navFinder
      in case maybeNavPath of
           Nothing -> []
           Just path ->
             let full = normalise (baseDir env </> path)
             in case findEntryByPath full (archive env) of
                  Nothing -> []
                  Just entry ->
                    let raw = TE.decodeUtf8 . B.toStrict $ fromEntry entry
                    in fromMaybe [] (scrapeStringLike raw (lndmkScraper [EpubType "toc", EpubType "landmarks", EpubType "bodymatter"]))

  getBookPath = bookPath
  getSpine = runReaderT resolveSpine
  loadChapter env path idx = runReaderT (getChapter path idx) env

openEpub :: FilePath -> IO (Either String EpubEnv)
openEpub path = do
  rawZip <- B.readFile path
  let arch = toArchive rawZip

  case getOpfPath arch of
    Nothing -> pure $ Left "Could not find OPF path"
    Just opfPath ->
      case findEntryByPath opfPath arch of
        Nothing -> pure $ Left "OPF not in archive"
        Just entry -> do
          let xml = T.unpack $ TE.decodeUtf8 $ B.toStrict $ fromEntry entry

          metaResult <- runExceptT $ getMetadata xml
          manResult <- runExceptT $ getManifest xml

          case (metaResult, manResult) of
            (Left err, _) -> pure $ Left $ "Metadata parse error: " ++ err
            (_, Left err) -> pure $ Left $ "Manifest parse error: " ++ err
            (Right meta, Right man) ->
              pure $
                Right $
                  EpubEnv
                    { archive = arch,
                      opfXml = xml,
                      baseDir = takeDirectory opfPath,
                      bookPath = path,
                      eMetadata = meta,
                      eManifest = man
                    }

getOpfPath :: Archive -> Maybe String
getOpfPath arch =
  maybe Nothing (\e -> getRootPath (TE.decodeUtf8 . B.toStrict $ fromEntry e)) (findEntryByPath "META-INF/container.xml" arch)

getRootPath :: T.Text -> Maybe String
getRootPath rawhtml =
  scrapeStringLike rawhtml $ T.unpack <$> attr "full-path" "rootfile"

ncxScraper :: Scraper T.Text [(FilePath, T.Text)]
ncxScraper = chroots "navPoint" $ do
  path <- T.unpack . T.takeWhile (/= '#') <$> attr "src" "content"
  title <- T.strip <$> text "navLabel"
  pure (path, title)

resolveSpine :: EpubAction [(InternalPath, T.Text)]
resolveSpine = do
  env <- ask
  let xmlStr = opfXml env

  spineResult <- liftIO $ runExceptT $ Codec.Epub.Parse.getSpine xmlStr
  let (DMan.Manifest items) = eManifest env

  case spineResult of
    Right (DSpin.Spine maybeTocId refs) -> do
      let lookupHref ident = DMan.mfiHref <$> find (\mi -> DMan.mfiId mi == ident) items
      let maybeTocPath = lookupHref maybeTocId
      let mNav = scrapeStringLike xmlStr navFinder

      tocMap <- case maybeTocPath of
        Nothing -> pure []
        Just path -> do
          let full = normalise (baseDir env </> path)
          case findEntryByPath full (archive env) of
            Nothing -> pure []
            Just e  -> do
              let raw = TE.decodeUtf8 . B.toStrict $ fromEntry e

              pure $ fromMaybe [] (scrapeStringLike raw ncxScraper)

      pure [(InternalPath p, fromMaybe ("Chapter " <> T.pack (show (i :: Int))) (lookup p tocMap)) | (ref, i) <- zip refs [1..] , let ident = DSpin.siIdRef ref , Just p <- [lookupHref ident]]

    _ -> pure []

getChapter :: (InternalPath, T.Text) -> ChapterIndex -> EpubAction Chapter
getChapter (InternalPath filename, tocTitle) idx = do
  env <- ask
  let full = normalise (baseDir env </> filename)
  case findEntryByPath full (archive env) of
    Nothing -> pure $ Chapter tocTitle "" idx
    Just e -> do
      let rawText = TE.decodeUtf8 . B.toStrict $ fromEntry e
      let withImages = embedImages env rawText

      let (_, content) = fromMaybe (tocTitle, "") $ scrapeStringLike withImages chapterScraper
      pure $ Chapter tocTitle content idx

getMimeFromManifest :: DMan.Manifest -> FilePath -> T.Text
getMimeFromManifest (DMan.Manifest items) relPath =
  case find (\item -> DMan.mfiHref item == relPath) items of
    Just item -> T.pack $ DMan.mfiMediaType item
    Nothing -> "image/jpeg"

-- translate a file path into base64 then formats it like "data:image/jpeg;<base64 string>"
findImage :: EpubEnv -> T.Text -> T.Text
findImage env path =
  let fullPath = normalise (baseDir env </> T.unpack path)
   in case findEntryByPath fullPath (archive env) of
        Nothing -> path
        Just entry -> "data:" <> mime <> ";base64," <> b64
          where
            rawData = B.toStrict $ fromEntry entry
            b64 = TE.decodeUtf8 $ B64.encode rawData
            mime = getMimeFromManifest (eManifest env) (T.unpack path)

imgScraper :: (Monad m) => EpubEnv -> ScraperT T.Text m [(T.Text, T.Text)]
imgScraper env = chroots "img" $ (\s h -> (h, T.replace s (findImage env s) h)) <$> attr "src" anySelector <*> html anySelector

applyReplacements :: T.Text -> [(T.Text, T.Text)] -> T.Text
applyReplacements = foldl' (\acc (old, new) -> T.replace old new acc)

embedImages :: EpubEnv -> T.Text -> T.Text
embedImages env htmlContent =
  maybe htmlContent (applyReplacements htmlContent) (scrapeStringLike htmlContent (imgScraper env))

chTitleScraper :: Scraper T.Text T.Text
chTitleScraper = do
  t <- text "h1" <|> text "h2" <|> text "h3" <|> text "title"
  let cleanT = T.strip t
  guard $ not $ T.null cleanT
  pure cleanT

chapterScraper :: Scraper T.Text (T.Text, T.Text)
chapterScraper = do
  title <- chTitleScraper <|> pure "Untitled Chapter"
  content <- chroot "body" (innerHTML anySelector) <|> innerHTML anySelector
  pure (title, content)