Marko Andjelic
3987c1a853
Right now chapter titles are completely plain, parsing the tags will allow us to render it properly. Revert chapterTitle addition and add it to seperate branch until its completed Delegating the task of implementing chapter title parsing into a different branch instead of having it incomplete in the main one Merge chtitle into main
143 lines
4.5 KiB
Haskell
143 lines
4.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module EpubParser
|
|
( EpubAction
|
|
, EpubEnv(..)
|
|
, openEpub
|
|
, getOpfPath
|
|
, myEnv
|
|
, resolveSpine
|
|
, getChapter
|
|
, getChapterTitle
|
|
, Tag(..)
|
|
) where
|
|
|
|
import Codec.Archive.Zip (Archive, findEntryByPath, fromEntry, toArchive)
|
|
|
|
import qualified Data.ByteString.Lazy as B
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import Control.Monad.Reader (ReaderT, MonadReader(ask), liftIO)
|
|
import Control.Monad.Except (runExceptT)
|
|
import System.FilePath (takeDirectory, (</>), normalise, takeExtension)
|
|
import Data.List (find)
|
|
|
|
import Codec.Epub.Parse (getManifest , getSpine)
|
|
import qualified Codec.Epub.Data.Manifest as DM
|
|
import qualified Codec.Epub.Data.Spine as DS
|
|
import qualified Data.ByteString.Base64 as B64
|
|
|
|
type EpubAction a = ReaderT EpubEnv IO a
|
|
|
|
data EpubEnv = EpubEnv
|
|
{ archive :: Archive
|
|
, opfXml :: String
|
|
, baseDir :: FilePath
|
|
, bookPath :: FilePath
|
|
}
|
|
|
|
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
|
|
pure $ Right $ EpubEnv arch xml (takeDirectory opfPath) path
|
|
|
|
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
|
|
|
|
myEnv :: Archive -> FilePath -> String -> FilePath -> EpubEnv
|
|
myEnv arch opfPath xml path = EpubEnv arch xml (takeDirectory opfPath) path
|
|
|
|
resolveSpine :: EpubAction [FilePath]
|
|
resolveSpine = do
|
|
env <- ask
|
|
let xmlStr = opfXml env
|
|
|
|
manifestResult <- liftIO $ runExceptT $ getManifest xmlStr
|
|
spineResult <- liftIO $ runExceptT $ getSpine xmlStr
|
|
|
|
case (manifestResult, spineResult) of
|
|
(Right (DM.Manifest items), Right (DS.Spine _ refs)) -> do
|
|
|
|
let lookupHref ident = DM.mfiHref <$> find (\mi -> DM.mfiId mi == ident) items
|
|
|
|
pure [ p | ref <- refs , let ident = DS.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 (archive env) (baseDir env) rawTags))
|
|
|
|
getMimeType :: FilePath -> T.Text
|
|
getMimeType path = T.pack $ "image/" ++ normalizeExt (drop 1 $ takeExtension path)
|
|
where
|
|
normalizeExt :: String -> String
|
|
normalizeExt ext
|
|
| ext == "jpg" = "jpeg"
|
|
| otherwise = ext
|
|
|
|
embedImages :: Archive -> FilePath -> [Tag T.Text] -> [Tag T.Text]
|
|
embedImages arch bdir = map processTag
|
|
where
|
|
processTag (TagOpen "img" attrs) = TagOpen "img" (map replaceSrc attrs)
|
|
processTag other = other
|
|
|
|
replaceSrc (name, value)
|
|
| name == "src" = ("src", findImage value)
|
|
| otherwise = (name, value)
|
|
|
|
findImage path =
|
|
let fullPath = normalise (bdir </> T.unpack path)
|
|
in case findEntryByPath fullPath arch of
|
|
Nothing -> path
|
|
Just entry ->
|
|
let rawData = B.toStrict $ fromEntry entry
|
|
b64 = TE.decodeUtf8 $ B64.encode rawData
|
|
in "data:" <> getMimeType fullPath <> ";base64," <> b64
|
|
|
|
-- TODO: Implement this, as it's not called yet
|
|
getChapterTitle :: [Tag T.Text] -> T.Text
|
|
getChapterTitle tags =
|
|
case dropWhile (not . isHeading) tags of
|
|
(_ : TagText t : _) -> T.strip t
|
|
_ -> "Untitled Chapter"
|
|
where
|
|
isHeading (TagOpen "h1" _) = True
|
|
isHeading (TagOpen "h2" _) = True
|
|
isHeading _ = False
|
|
|
|
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)
|
|
go (x:xs) = x : go xs
|
|
|
|
dropUntilClose _ [] = []
|
|
dropUntilClose name (TagClose n : xs) | n == name = xs
|
|
dropUntilClose name (_ : xs) = dropUntilClose name xs
|