149 lines
4.8 KiB
Haskell
149 lines
4.8 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 Text.HTML.TagSoup
|
|
|
|
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
|
|
|
|
|
|
|
|
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
|
|
|
|
-- TODO: Implement this, as it's not called yet
|
|
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) -- The heading content, the outer tags will be detected such as h1 but this makes sure that every other inner tag is ignored yet the inner text will still be visible
|
|
|
|
_ -> "Untitled Chapter"
|
|
|
|
where
|
|
ishding (TagOpen n _ ) = n `elem` ["h1", "h2", "h3"]
|
|
ishding _ = False
|
|
isclose n (TagClose n') = n == n'
|
|
isclose _ _ = False
|