forked from marko/svitak
145 lines
5.2 KiB
Haskell
145 lines
5.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module EpubParser
|
|
( EpubAction,
|
|
EpubEnv (..),
|
|
openEpub,
|
|
getOpfPath,
|
|
resolveSpine,
|
|
getChapter,
|
|
getChapterTitle,
|
|
Tag (..),
|
|
)
|
|
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.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 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 Text.HTML.TagSoup (Tag (..), parseTags, renderTags)
|
|
import Control.Applicative ((<|>))
|
|
import Types (EpubEnv(..), EpubAction)
|
|
|
|
|
|
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 FilePath
|
|
getOpfPath arch =
|
|
case findEntryByPath "META-INF/container.xml" arch of
|
|
Nothing -> Nothing
|
|
Just entry -> getRootPath (parseTags . T.unpack . TE.decodeUtf8 . B.toStrict $ fromEntry entry)
|
|
|
|
getRootPath :: [Tag String] -> Maybe FilePath
|
|
getRootPath [] = Nothing
|
|
getRootPath (TagOpen "rootfile" attrs : _) = lookup "full-path" attrs
|
|
getRootPath (_ : xs) = getRootPath xs
|
|
|
|
resolveSpine :: EpubAction [FilePath]
|
|
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 _ refs) -> do
|
|
let lookupHref ident = DMan.mfiHref <$> find (\mi -> DMan.mfiId mi == ident) items
|
|
pure [p | ref <- refs, let ident = DSpin.siIdRef ref, Just p <- [lookupHref ident]]
|
|
_ -> pure []
|
|
|
|
getChapter :: FilePath -> EpubAction [Tag T.Text]
|
|
getChapter filename = do
|
|
env <- ask
|
|
let full = normalise (baseDir env </> filename)
|
|
case findEntryByPath full (archive env) of
|
|
Nothing -> pure []
|
|
Just e -> do
|
|
let rawTags = parseTags . TE.decodeUtf8 . B.toStrict $ fromEntry e
|
|
pure (filterJunk (embedImages env rawTags))
|
|
|
|
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"
|
|
|
|
-- Replace img tags with base64
|
|
embedImages :: EpubEnv -> [Tag T.Text] -> [Tag T.Text]
|
|
embedImages env = map processTag
|
|
where
|
|
processTag (TagOpen "img" attrs) = TagOpen "img" (map replaceSrc attrs)
|
|
processTag other = other
|
|
|
|
replaceSrc (name, value)
|
|
| name == "src" = ("src", findImage value) -- guards to check for src otherwise output the argument it was given without changes
|
|
| otherwise = (name, value)
|
|
|
|
findImage path =
|
|
let fullPath = normalise (baseDir env </> T.unpack path)
|
|
in case findEntryByPath fullPath (archive env) of
|
|
Nothing -> path
|
|
Just entry ->
|
|
let rawData = B.toStrict $ fromEntry entry
|
|
b64 = TE.decodeUtf8 $ B64.encode rawData
|
|
mime = getMimeFromManifest (eManifest env) (T.unpack path)
|
|
in "data:" <> mime <> ";base64," <> b64
|
|
|
|
filterJunk :: [Tag T.Text] -> [Tag T.Text]
|
|
filterJunk = go
|
|
where
|
|
go [] = []
|
|
go (TagOpen name _ : xs) | name `elem` ["script", "style", "head", "link", "meta"] = go (dropUntilClose name xs) -- these are elems we want to filter out
|
|
go (x : xs) = x : go xs
|
|
|
|
dropUntilClose _ [] = []
|
|
dropUntilClose name (TagClose n : xs) | n == name = xs
|
|
dropUntilClose name (_ : xs) = dropUntilClose name xs
|
|
|
|
getChapterTitle :: [Tag T.Text] -> T.Text
|
|
getChapterTitle tags =
|
|
case dropWhile (not . ishding) tags of
|
|
(TagOpen x _ : xs) -> T.strip $ innerText (takeWhile (not . isclose x) xs) -- get the raw heading content, remove nested tags
|
|
_ -> "Untitled Chapter"
|
|
where
|
|
ishding (TagOpen n _) = n `elem` ["h1", "h2", "h3"]
|
|
ishding _ = False
|
|
isclose n (TagClose n') = n == n'
|
|
isclose _ _ = False
|