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)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as B
import Data.List (find)
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 (..))

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 =
  case findEntryByPath "META-INF/container.xml" arch of
    Nothing -> Nothing
    Just entry -> getRootPath (TE.decodeUtf8 . B.toStrict $ fromEntry entry)

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 [(FilePath, T.Text)]
resolveSpine = do
  env <- ask
  let xmlStr = opfXml env

  spineResult <- liftIO $ runExceptT $ 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

      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 [(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 :: (FilePath, T.Text) -> Int -> EpubAction Chapter
getChapter (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)