forked from marko/svitak
144 lines
4.6 KiB
Haskell
144 lines
4.6 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
|
|
|
|
-- 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
|