forked from marko/svitak
refactor: streaming loader, hierarchical TOC, parser robustness
Rework the reader around a clean BookInfo interface and lazy chapter loading. Types/parser: - BookInfo now splits into loadStructure (cheap: spine refs + TOC tree) and renderChapter (one chapter on demand). EpubEnv carries the parsed archive. - resolveZipPath collapses ./.. and strips #fragments (normalise does not), so relative hrefs like ../Images/x.jpg resolve; used for chapters and images. - decodeEntry tolerates encodings: UTF-8/UTF-16 BOMs, Latin-1 fallback instead of throwing on invalid bytes. - Skip spine items with no manifest entry instead of throwing an error. - Scan the zip for a .opf if container.xml is missing. - Image inlining rewrites the src URL string, not the whole <img> tag (scalpel re-serialises tags, so a whole-tag replace silently missed self-closing imgs). Navigation: - Hierarchical TOC: ncxToc (EPUB 2), navToc (EPUB 3), guideToc (<guide> fallback). Nested scrapers use atDepth 1 to take only direct children. UI: - Streaming: render the opened chapter on demand, cache it, preload neighbours so arrow paging is instant with a placeholder that covers uncached jumps. - Sidebar shows the TOC tree with CSS styling. Clicks scroll to #fragments. - wrapHtml wraps each body in a full HTML document for reliable WebKit render. Test: 'svitak-test <book> <idx>' dumps one rendered chapter. cabal test stanza fixed to list all needed modules/deps.
This commit is contained in:
parent
269c2055f1
commit
2011d638b0
GPG key ID:
9C5E99C8C682FB59
7 changed files with 738 additions and 427 deletions
|
|
@ -1,192 +1,272 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
-- The sole BookInfo instance lives here rather than in Types (which must not
|
||||
-- depend on the parser); the orphan warning is expected.
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
-- | Turns a @.epub@ file into a 'BookStructure' (cheap) plus on-demand
|
||||
-- 'Chapter' rendering.
|
||||
--
|
||||
-- 1. 'openEpub' — unzip, locate the OPF, parse metadata\/manifest\/version
|
||||
-- 2. 'loadStructure' — resolve the spine (reading order) and the TOC tree
|
||||
-- 3. 'renderChapter' — read one chapter and inline its images, when visited
|
||||
module EpubParser
|
||||
( EpubAction,
|
||||
EpubEnv (..),
|
||||
( EpubEnv (..),
|
||||
openEpub,
|
||||
getOpfPath,
|
||||
resolveSpine,
|
||||
getChapter,
|
||||
)
|
||||
where
|
||||
|
||||
import Codec.Archive.Zip (Archive, findEntryByPath, fromEntry, toArchive)
|
||||
import Codec.Archive.Zip (Archive, Entry, filesInArchive, findEntryByPath, fromEntry, toArchive)
|
||||
import qualified Codec.Epub.Data.Manifest as DMan
|
||||
import qualified Codec.Epub.Data.Metadata as DMeta
|
||||
import Codec.Epub.Data.Package (Package (..))
|
||||
import qualified Codec.Epub.Data.Spine as DSpin
|
||||
import Codec.Epub.Parse (getManifest, getMetadata, getSpine)
|
||||
import Codec.Epub.Parse (getManifest, getMetadata, getPackage)
|
||||
import qualified Codec.Epub.Parse as EParse
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.Except (runExceptT, ExceptT, throwError)
|
||||
import Control.Monad.Reader (MonadReader (ask), runReaderT)
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Reader (ask, runReaderT)
|
||||
import Control.Monad.Trans (lift)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
import Data.List (find, foldl')
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.List (find, isSuffixOf)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
|
||||
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 (..), InternalPath(..), ChapterIndex(..), BookInfo(..), EpubType(..))
|
||||
import Navigation (navFinder, lndmkmap, getLandmarks)
|
||||
import Codec.Epub.Parse (getPackage)
|
||||
import Codec.Epub.Data.Package (Package(..))
|
||||
import qualified Codec.Epub.Data.Metadata as DMeta
|
||||
import System.FilePath (joinPath, splitDirectories, takeDirectory, (</>))
|
||||
import Text.HTML.Scalpel (Scraper, anySelector, attr, chroots, innerHTML, scrapeStringLike)
|
||||
import Types
|
||||
( BookInfo (..),
|
||||
BookStructure (..),
|
||||
Chapter (..),
|
||||
ChapterIndex (..),
|
||||
ChapterRef (..),
|
||||
EpubAction,
|
||||
EpubEnv (..),
|
||||
InternalPath (..),
|
||||
TocEntry (..),
|
||||
)
|
||||
import Navigation (RawToc (..), guideToc, navDocHref, navToc, ncxToc)
|
||||
|
||||
-- | The UI talks to a book only through this interface, so it never has to
|
||||
-- know it's dealing with an EPUB specifically.
|
||||
instance BookInfo EpubEnv where
|
||||
getTitle env = fromMaybe "Unknown Title" $ T.pack . DMeta.titleText <$> listToMaybe (DMeta.metaTitles $ eMetadata env)
|
||||
bookTitle env =
|
||||
fromMaybe "Unknown Title" $
|
||||
T.pack . DMeta.titleText <$> listToMaybe (DMeta.metaTitles (eMetadata env))
|
||||
|
||||
getAuthors env = map (T.pack . DMeta.creatorText) $ DMeta.metaCreators $ eMetadata env
|
||||
bookAuthors env = map (T.pack . DMeta.creatorText) (DMeta.metaCreators (eMetadata env))
|
||||
|
||||
getLandmarks = Navigation.getLandmarks
|
||||
bookFilePath = bookPath
|
||||
|
||||
getBookPath = bookPath
|
||||
loadStructure env = runExceptT (runReaderT buildStructure env)
|
||||
renderChapter env ref = runExceptT (runReaderT (renderRef ref) env)
|
||||
|
||||
getSpine env = runExceptT (runReaderT resolveSpine env)
|
||||
loadChapter env path idx = runExceptT (runReaderT (getChapter path idx) env)
|
||||
--------------------------------------------------------------------------------
|
||||
-- Opening the archive
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Read the @.epub@ off disk and gather everything the parser needs. Returns
|
||||
-- @Left@ with a human-readable reason on any failure.
|
||||
openEpub :: FilePath -> IO (Either String EpubEnv)
|
||||
openEpub path = do
|
||||
rawZip <- B.readFile path
|
||||
let arch = toArchive rawZip
|
||||
arch <- toArchive <$> B.readFile path
|
||||
case getOpfPath arch >>= \opf -> (,) opf <$> findEntryByPath opf arch of
|
||||
Nothing -> pure (Left "Could not find the OPF package document")
|
||||
Just (opfPath, entry) -> do
|
||||
let xml = T.unpack (decodeEntry entry)
|
||||
meta <- runExceptT (getMetadata xml)
|
||||
man <- runExceptT (getManifest xml)
|
||||
ver <- runExceptT (detectVersion xml)
|
||||
pure $ case (meta, man, ver) of
|
||||
(Left err, _, _) -> Left ("Metadata parse error: " ++ err)
|
||||
(_, Left err, _) -> Left ("Manifest parse error: " ++ err)
|
||||
(_, _, Left err) -> Left ("Version parse error: " ++ err)
|
||||
(Right m, Right mn, Right v) ->
|
||||
Right
|
||||
EpubEnv
|
||||
{ archive = arch,
|
||||
opfXml = xml,
|
||||
baseDir = takeDirectory opfPath,
|
||||
bookPath = path,
|
||||
eMetadata = m,
|
||||
eManifest = mn,
|
||||
eVersion = T.pack v
|
||||
}
|
||||
|
||||
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
|
||||
verResult <- runExceptT $ detectVersion xml
|
||||
|
||||
case (metaResult, manResult, verResult) of
|
||||
(Left err, _, _) -> pure $ Left $ "Metadata parse error: " ++ err
|
||||
(_, Left err, _) -> pure $ Left $ "Manifest parse error: " ++ err
|
||||
(_, _, Left err) -> pure $ Left $ "Version parse error: " ++ err
|
||||
(Right meta, Right man, Right v) ->
|
||||
pure $
|
||||
Right $
|
||||
EpubEnv
|
||||
{ archive = arch,
|
||||
opfXml = xml,
|
||||
baseDir = takeDirectory opfPath,
|
||||
bookPath = path,
|
||||
eMetadata = meta,
|
||||
eManifest = man,
|
||||
eVersion = T.pack v
|
||||
}
|
||||
|
||||
(Left err, _, _) -> pure $ Left $ "Metadata error: " ++ err
|
||||
(_, Left err, _) -> pure $ Left $ "Manifest error: " ++ err
|
||||
(_, _, Left err) -> pure $ Left $ "Version error: " ++ err
|
||||
|
||||
getOpfPath :: Archive -> Maybe String
|
||||
getOpfPath arch =
|
||||
maybe Nothing (\e -> getRootPath (TE.decodeUtf8 . B.toStrict $ fromEntry e)) (findEntryByPath "META-INF/container.xml" arch)
|
||||
|
||||
getRootPath :: T.Text -> Maybe String
|
||||
getRootPath rawhtml =
|
||||
scrapeStringLike rawhtml $ T.unpack <$> attr "full-path" "rootfile"
|
||||
|
||||
resolveSpine :: EpubAction [(InternalPath, T.Text)]
|
||||
resolveSpine = do
|
||||
env <- ask
|
||||
let xmlStr = opfXml env
|
||||
let (DMan.Manifest items) = eManifest env
|
||||
|
||||
spineResult <- lift $ Codec.Epub.Parse.getSpine xmlStr
|
||||
|
||||
case spineResult of
|
||||
DSpin.Spine maybeTocId refs -> do
|
||||
let lookupHref ident = DMan.mfiHref <$> find (\mi -> DMan.mfiId mi == ident) items
|
||||
let mNavPath = scrapeStringLike xmlStr navFinder
|
||||
tocMap <- case mNavPath of
|
||||
Just navPath -> extractTocFromEntry (baseDir env </> navPath)
|
||||
Nothing -> case lookupHref maybeTocId of
|
||||
Just ncxPath -> extractTocFromEntry (baseDir env </> ncxPath)
|
||||
Nothing -> throwError "Could not locate a Table of Contents."
|
||||
let buildChapter (ref, i) = do
|
||||
let ident = DSpin.siIdRef ref
|
||||
case lookupHref ident of
|
||||
Nothing -> throwError $ "Manifest missing entry for spine item: " ++ ident
|
||||
Just p ->
|
||||
let title = fromMaybe ("Chapter " <> T.pack (show i)) (lookup p tocMap)
|
||||
in pure (InternalPath p, title)
|
||||
|
||||
mapM buildChapter (zip refs [1..])
|
||||
|
||||
extractTocFromEntry :: FilePath -> EpubAction [(String, T.Text)]
|
||||
extractTocFromEntry fullPath = do
|
||||
env <- ask
|
||||
case findEntryByPath (normalise fullPath) (archive env) of
|
||||
Nothing -> pure []
|
||||
Just e -> do
|
||||
let raw = TE.decodeUtf8 . B.toStrict $ fromEntry e
|
||||
let types = [EpubType "toc", EpubType "bodymatter"]
|
||||
pure $ fromMaybe [] (scrapeStringLike raw (lndmkmap types) <|> scrapeStringLike raw ncxScraper)
|
||||
|
||||
getChapter :: (InternalPath, T.Text) -> ChapterIndex -> EpubAction Chapter
|
||||
getChapter (InternalPath filename, tocTitle) idx = do
|
||||
env <- ask
|
||||
let bare = takeWhile (/= '#') filename
|
||||
let full = normalise (baseDir env </> bare)
|
||||
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)
|
||||
|
||||
ncxScraper :: Scraper T.Text [(String, T.Text)]
|
||||
ncxScraper = chroots "navPoint" $
|
||||
(,) <$> (T.unpack <$> attr "src" "content") <*> (T.strip <$> text "navLabel")
|
||||
-- | Locate the OPF. Normally it's announced in @META-INF/container.xml@; if
|
||||
-- that's missing or malformed, fall back to scanning the archive for a @.opf@.
|
||||
getOpfPath :: Archive -> Maybe FilePath
|
||||
getOpfPath arch = fromContainer <|> scanArchive
|
||||
where
|
||||
fromContainer = do
|
||||
entry <- findEntryByPath "META-INF/container.xml" arch
|
||||
scrapeStringLike (decodeEntry entry) (T.unpack <$> attr "full-path" "rootfile")
|
||||
scanArchive = find (".opf" `isSuffixOf`) (filesInArchive arch)
|
||||
|
||||
detectVersion :: String -> ExceptT String IO String
|
||||
detectVersion = fmap pkgVersion . getPackage
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Structure (spine + table of contents)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Resolve the reading order and the TOC tree without rendering any bodies.
|
||||
-- Spine items whose manifest entry is missing are skipped rather than aborting
|
||||
-- the whole load.
|
||||
buildStructure :: EpubAction BookStructure
|
||||
buildStructure = do
|
||||
env <- ask
|
||||
let DMan.Manifest items = eManifest env
|
||||
hrefOf ident = DMan.mfiHref <$> find ((== ident) . DMan.mfiId) items
|
||||
|
||||
DSpin.Spine tocId refs <- lift (EParse.getSpine (opfXml env))
|
||||
toc <- buildToc hrefOf tocId
|
||||
|
||||
let titles = M.fromListWith (\_new old -> old) [(tocTarget t, tocLabel t) | t <- flattenToc toc]
|
||||
paths = mapMaybe (fmap (InternalPath . toFullPath env) . hrefOf . DSpin.siIdRef) refs
|
||||
titleFor path n = M.findWithDefault ("Chapter " <> T.pack (show (n + 1))) path titles
|
||||
chapterRefs =
|
||||
[ ChapterRef path (titleFor path n) (ChapterIndex n)
|
||||
| (path, n) <- zip paths [0 ..]
|
||||
]
|
||||
pure (BookStructure chapterRefs toc)
|
||||
|
||||
-- | Build the TOC tree, trying each source in order of richness:
|
||||
-- EPUB 3 nav document, then EPUB 2 NCX, then the EPUB 2 @\<guide\>@.
|
||||
buildToc :: (String -> Maybe FilePath) -> String -> EpubAction [TocEntry]
|
||||
buildToc hrefOf tocId = do
|
||||
env <- ask
|
||||
let fromDoc mhref scraper = case mhref of
|
||||
Nothing -> pure []
|
||||
Just href -> readTocDoc (toFullPath env href) scraper
|
||||
nav <- fromDoc (navDocHref (opfXml env)) navToc
|
||||
ncx <- fromDoc (hrefOf tocId) ncxToc
|
||||
let guide = resolveRaws (baseDir env) (fromMaybe [] (scrapeStringLike (T.pack (opfXml env)) guideToc))
|
||||
pure (firstNonEmpty [nav, ncx, guide])
|
||||
|
||||
-- | Read a TOC document and resolve its entries' hrefs against its own
|
||||
-- location.
|
||||
readTocDoc :: FilePath -> Scraper T.Text [RawToc] -> EpubAction [TocEntry]
|
||||
readTocDoc docPath scraper = do
|
||||
env <- ask
|
||||
pure $ case findEntry env docPath of
|
||||
Nothing -> []
|
||||
Just entry -> resolveRaws (takeDirectory docPath) (fromMaybe [] (scrapeStringLike (decodeEntry entry) scraper))
|
||||
|
||||
-- | Resolve raw (document-relative) hrefs into full archive paths, splitting
|
||||
-- off any @#fragment@.
|
||||
resolveRaws :: FilePath -> [RawToc] -> [TocEntry]
|
||||
resolveRaws dir = map go
|
||||
where
|
||||
go (RawToc label href kids) =
|
||||
let (path, frag) = breakFragment href
|
||||
in TocEntry label (InternalPath (resolveZipPath (dir </> path))) frag (resolveRaws dir kids)
|
||||
|
||||
flattenToc :: [TocEntry] -> [TocEntry]
|
||||
flattenToc = concatMap (\t -> t : flattenToc (tocChildren t))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Rendering a single chapter
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Read a chapter file and render its @\<body\>@ to self-contained HTML.
|
||||
renderRef :: ChapterRef -> EpubAction Chapter
|
||||
renderRef ref = do
|
||||
env <- ask
|
||||
let InternalPath p = refPath ref
|
||||
pure $ case findEntry env p of
|
||||
Nothing -> Chapter (refPath ref) (refTitle ref) "" (refIndex ref)
|
||||
Just entry ->
|
||||
let withImages = embedImages env (takeDirectory p) (decodeEntry entry)
|
||||
body = fromMaybe "" (scrapeStringLike withImages bodyScraper)
|
||||
in Chapter (refPath ref) (refTitle ref) body (refIndex ref)
|
||||
|
||||
-- | Grab the contents of @\<body\>@, falling back to the whole document.
|
||||
bodyScraper :: Scraper T.Text T.Text
|
||||
bodyScraper = innerHTML "body" <|> innerHTML anySelector
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Inlining images
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Inline images by rewriting each distinct @<img>@ @src@ URL to a base64
|
||||
-- @data:@ URI, so the rendered HTML is self-contained. We replace the URL
|
||||
-- string itself (not the whole tag) because scalpel re-serialises tags — e.g.
|
||||
-- @<img .../>@ becomes @<img ...></img>@ — which would never match the source
|
||||
-- text. Image @src@s are relative to the chapter file, hence @chapterDir@.
|
||||
embedImages :: EpubEnv -> FilePath -> T.Text -> T.Text
|
||||
embedImages env chapterDir content =
|
||||
foldr embed content (distinct (fromMaybe [] (scrapeStringLike content imgSrcs)))
|
||||
where
|
||||
imgSrcs = chroots "img" (attr "src" anySelector) :: Scraper T.Text [T.Text]
|
||||
embed src acc = T.replace src (dataUri env chapterDir src) acc
|
||||
distinct = M.keys . M.fromList . map (\s -> (s, ()))
|
||||
|
||||
-- | Turn an image href into a @data:<mime>;base64,<...>@ URI, or leave it
|
||||
-- untouched if the file isn't in the archive.
|
||||
dataUri :: EpubEnv -> FilePath -> T.Text -> T.Text
|
||||
dataUri env chapterDir src =
|
||||
case findEntryByPath path (archive env) of
|
||||
Nothing -> src
|
||||
Just entry ->
|
||||
let b64 = TE.decodeUtf8 (B64.encode (B.toStrict (fromEntry entry)))
|
||||
in "data:" <> mimeFor env path <> ";base64," <> b64
|
||||
where
|
||||
path = resolveZipPath (chapterDir </> T.unpack src)
|
||||
|
||||
-- | An entry's declared media type, looked up in the manifest by full path.
|
||||
mimeFor :: EpubEnv -> FilePath -> T.Text
|
||||
mimeFor env fullPath =
|
||||
case find ((== fullPath) . toFullPath env . DMan.mfiHref) items of
|
||||
Just item -> T.pack (DMan.mfiMediaType item)
|
||||
Nothing -> "image/jpeg"
|
||||
where
|
||||
DMan.Manifest items = eManifest env
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Paths, decoding, small helpers
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
findEntry :: EpubEnv -> FilePath -> Maybe Entry
|
||||
findEntry env path = findEntryByPath path (archive env)
|
||||
|
||||
-- | Resolve a manifest/TOC href (relative to the OPF) to a full archive path.
|
||||
toFullPath :: EpubEnv -> FilePath -> FilePath
|
||||
toFullPath env href = resolveZipPath (baseDir env </> href)
|
||||
|
||||
-- | Normalise an already-joined path: drop any @#fragment@ and collapse @.@
|
||||
-- and @..@ segments. 'System.FilePath.normalise' does /not/ collapse @..@,
|
||||
-- which is why relative hrefs like @../Images/p1.jpg@ would otherwise miss.
|
||||
resolveZipPath :: FilePath -> FilePath
|
||||
resolveZipPath raw =
|
||||
joinPath (reverse (foldl step [] (splitDirectories (fst (breakFragment raw)))))
|
||||
where
|
||||
step acc "." = acc
|
||||
step (_ : rest) ".." = rest
|
||||
step acc ".." = acc
|
||||
step acc seg = seg : acc
|
||||
|
||||
-- | Split an href into its path and (un-@#@-prefixed) fragment.
|
||||
breakFragment :: FilePath -> (FilePath, T.Text)
|
||||
breakFragment href = (path, T.pack (drop 1 frag))
|
||||
where
|
||||
(path, frag) = break (== '#') href
|
||||
|
||||
firstNonEmpty :: [[a]] -> [a]
|
||||
firstNonEmpty = fromMaybe [] . find (not . null)
|
||||
|
||||
-- | Decode a zip entry to text, honouring a BOM and tolerating non-UTF-8 bytes
|
||||
-- (falling back to Latin-1) rather than throwing.
|
||||
decodeEntry :: Entry -> T.Text
|
||||
decodeEntry = decodeBytes . B.toStrict . fromEntry
|
||||
|
||||
decodeBytes :: BS.ByteString -> T.Text
|
||||
decodeBytes bs
|
||||
| "\xEF\xBB\xBF" `BS.isPrefixOf` bs = decodeBytes (BS.drop 3 bs)
|
||||
| "\xFF\xFE" `BS.isPrefixOf` bs = TE.decodeUtf16LE (BS.drop 2 bs)
|
||||
| "\xFE\xFF" `BS.isPrefixOf` bs = TE.decodeUtf16BE (BS.drop 2 bs)
|
||||
| otherwise = either (const (TE.decodeLatin1 bs)) id (TE.decodeUtf8' bs)
|
||||
|
|
|
|||
|
|
@ -1,74 +1,71 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Scrapers that turn a table-of-contents document into a /tree/ of raw
|
||||
-- entries. Two formats are supported:
|
||||
--
|
||||
-- * EPUB 2 — an NCX file with nested @\<navPoint\>@s.
|
||||
-- * EPUB 3 — a nav document with nested @\<ol\>@\/@\<li\>@ lists.
|
||||
--
|
||||
-- Hrefs are left relative here; 'EpubParser' resolves them against the TOC
|
||||
-- document's location. We use 'atDepth' so each recursion level only picks up
|
||||
-- its /direct/ children (otherwise scalpel's descendant matching would flatten
|
||||
-- the hierarchy and duplicate nested nodes).
|
||||
module Navigation
|
||||
( navFinder,
|
||||
lndmkScraper,
|
||||
lndmkmap,
|
||||
getLandmarks
|
||||
( RawToc (..),
|
||||
navDocHref,
|
||||
ncxToc,
|
||||
navToc,
|
||||
guideToc,
|
||||
)
|
||||
where
|
||||
|
||||
import Text.HTML.Scalpel (Scraper, attr, (@:), (@=), chroot, chroots, text, match, scrapeStringLike)
|
||||
import Types (NavItem(..), EpubType (..), InternalPath(..), EpubEnv(..))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad (guard)
|
||||
import Codec.Archive.Zip
|
||||
import Control.Applicative ((<|>))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import System.FilePath (normalise, (</>))
|
||||
import Text.HTML.Scalpel (Scraper, atDepth, attr, chroot, chroots, scrapeStringLike, text, (@:), (@=))
|
||||
|
||||
-- ------------------------------------------------------------
|
||||
-- EPub 3 navigation
|
||||
-- ------------------------------------------------------------
|
||||
-- The epub-metadata library is good for epub 2.x. As there could be a seperate nav.xhtml file in the epub 3.x spec, we need these functions to support it.
|
||||
-- | A TOC node with an as-yet-unresolved (document-relative) href.
|
||||
data RawToc = RawToc
|
||||
{ rawLabel :: T.Text,
|
||||
rawHref :: FilePath,
|
||||
rawChildren :: [RawToc]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
navFinder :: Scraper String FilePath
|
||||
navFinder = attr "href" ("item" @: ["properties" @= "nav"])
|
||||
|
||||
itemScraper :: [EpubType] -> Scraper T.Text NavItem
|
||||
itemScraper allowedTypes = do
|
||||
label <- text "a"
|
||||
path <- attr "href" "a"
|
||||
rawTypes <- fromMaybe "" <$> optional (attr "epub:type" "a")
|
||||
|
||||
let foundTypes = map EpubType $ T.words rawTypes
|
||||
guard $ any (`elem` allowedTypes) foundTypes
|
||||
|
||||
pure $ NavItem label (InternalPath $ T.unpack path) foundTypes
|
||||
|
||||
lndmkScraper :: [EpubType] -> Scraper T.Text [NavItem]
|
||||
lndmkScraper labels =
|
||||
chroot ("nav" @: [match navPredicate]) $ chroots "li" (itemScraper labels)
|
||||
-- | The EPUB 3 navigation document's href, declared in the OPF manifest as the
|
||||
-- item carrying @properties="nav"@.
|
||||
navDocHref :: String -> Maybe FilePath
|
||||
navDocHref opf =
|
||||
scrapeStringLike opf (attr "href" ("item" @: ["properties" @= "nav"]))
|
||||
|
||||
-- | EPUB 2: walk the @\<navMap\>@ of nested @\<navPoint\>@s.
|
||||
ncxToc :: Scraper T.Text [RawToc]
|
||||
ncxToc = chroot "navMap" points
|
||||
where
|
||||
navPredicate "epub:type" xs = EpubType (T.pack xs) `elem` labels
|
||||
navPredicate _ _ = False
|
||||
points = chroots ("navPoint" `atDepth` 1) node
|
||||
node =
|
||||
RawToc
|
||||
<$> (T.strip <$> text ("navLabel" `atDepth` 1))
|
||||
<*> (T.unpack <$> attr "src" ("content" `atDepth` 1))
|
||||
<*> points
|
||||
|
||||
lndmkmap :: [EpubType] -> Scraper T.Text [(String, T.Text)]
|
||||
lndmkmap types =
|
||||
map (\item -> (unpackPath (navPath item), navLabel item)) <$> lndmkScraper types
|
||||
-- | EPUB 3: walk @\<nav epub:type="toc"\>@'s nested @\<ol\>@\/@\<li\>@ lists.
|
||||
navToc :: Scraper T.Text [RawToc]
|
||||
navToc = chroot ("nav" @: ["epub:type" @= "toc"]) (chroot "ol" items)
|
||||
where
|
||||
unpackPath (InternalPath p) = p
|
||||
items = chroots ("li" `atDepth` 1) node
|
||||
node =
|
||||
RawToc
|
||||
<$> (T.strip <$> text ("a" `atDepth` 1))
|
||||
<*> (T.unpack <$> attr "href" ("a" `atDepth` 1))
|
||||
<*> (chroot ("ol" `atDepth` 1) items <|> pure [])
|
||||
|
||||
--------------------------------------------------------
|
||||
-- dispatching --
|
||||
--------------------------------------------------------
|
||||
|
||||
getLandmarks :: EpubEnv -> [NavItem]
|
||||
getLandmarks env =
|
||||
case eVersion env of
|
||||
"2.0" -> []
|
||||
"3.0" ->
|
||||
case scrapeStringLike (opfXml env) navFinder of
|
||||
Nothing -> []
|
||||
Just relPath ->
|
||||
let fullPath = normalise $ (baseDir env) </> relPath
|
||||
in case findEntryByPath fullPath (archive env) of
|
||||
Nothing -> []
|
||||
Just entry ->
|
||||
let content = TE.decodeUtf8 . B.toStrict $ fromEntry entry
|
||||
types = map EpubType ["toc", "landmarks", "bodymatter"]
|
||||
scrp = lndmkScraper types
|
||||
in fromMaybe [] $ scrapeStringLike content scrp
|
||||
-- | EPUB 2 @\<guide\>@: a flat list of @\<reference\>@s (cover, toc, start, …).
|
||||
-- Used as a last-resort TOC when there's no NCX or nav document.
|
||||
guideToc :: Scraper T.Text [RawToc]
|
||||
guideToc = chroot "guide" $ chroots "reference" node
|
||||
where
|
||||
node =
|
||||
RawToc
|
||||
<$> (T.strip <$> attr "title" "reference")
|
||||
<*> (T.unpack <$> attr "href" "reference")
|
||||
<*> pure []
|
||||
|
|
|
|||
51
app/State.hs
51
app/State.hs
|
|
@ -1,41 +1,22 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module State
|
||||
( initialState,
|
||||
prepareView
|
||||
)
|
||||
where
|
||||
-- | The mutable application state's initial value. Navigation logic lives in
|
||||
-- the UI, which renders chapters lazily into 'stCache'.
|
||||
module State (initialState) where
|
||||
|
||||
import Types (AppState(..), Chapter(chapterTags, chapterTitle), ChapterView(..), EpubEnv, ChapterIndex(..))
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import Types (AppState (..), ChapterIndex (..))
|
||||
|
||||
-- Get an element from a list without crashing
|
||||
safeGet :: ChapterIndex -> [a] -> Maybe a
|
||||
safeGet (ChapterIndex n) xs
|
||||
| n < 0 = Nothing
|
||||
| otherwise = case drop n xs of
|
||||
(x : _) -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
-- loading template
|
||||
initialState :: EpubEnv -> AppState
|
||||
initialState env =
|
||||
-- | Empty state shown while the book's structure loads in the background.
|
||||
initialState :: T.Text -> FilePath -> AppState
|
||||
initialState title path =
|
||||
AppState
|
||||
{ cEnv = env,
|
||||
cIdx = ChapterIndex 0,
|
||||
cSpine = [],
|
||||
bTitle = "Svitak - Loading...",
|
||||
zoomlvl = 1.0,
|
||||
activeTask = Nothing,
|
||||
cAllChapters = [],
|
||||
taskVersion = 0
|
||||
}
|
||||
|
||||
-- prepare the data for the UI
|
||||
prepareView :: AppState -> ChapterIndex -> Maybe ChapterView
|
||||
prepareView st index = do
|
||||
chapter <- safeGet index (cAllChapters st)
|
||||
pure $ ChapterView
|
||||
{ viewTitle = bTitle st <> " - " <> chapterTitle chapter
|
||||
, viewHtml = chapterTags chapter
|
||||
, viewIdx = index
|
||||
{ stRefs = [],
|
||||
stToc = [],
|
||||
stCache = M.empty,
|
||||
stIndex = ChapterIndex 0,
|
||||
stZoom = 1.0,
|
||||
stTitle = title,
|
||||
stBookPath = path
|
||||
}
|
||||
|
|
|
|||
161
app/Types.hs
161
app/Types.hs
|
|
@ -1,47 +1,117 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
-- | Shared types for the whole reader. The parser ('EpubParser') produces a
|
||||
-- 'BookStructure' cheaply and renders each 'Chapter' on demand; the UI
|
||||
-- consumes both through the 'BookInfo' interface.
|
||||
module Types
|
||||
( EpubEnv(..),
|
||||
ChapterView(..),
|
||||
Chapter(..),
|
||||
AppState(..),
|
||||
UserAction(..),
|
||||
( -- * Identifiers
|
||||
ChapterIndex (..),
|
||||
InternalPath (..),
|
||||
|
||||
-- * Book content
|
||||
Chapter (..),
|
||||
ChapterRef (..),
|
||||
TocEntry (..),
|
||||
BookStructure (..),
|
||||
|
||||
-- * The book interface the UI talks to
|
||||
BookInfo (..),
|
||||
|
||||
-- * UI state
|
||||
AppState (..),
|
||||
UserAction (..),
|
||||
|
||||
-- * EPUB environment
|
||||
EpubEnv (..),
|
||||
EpubAction,
|
||||
NavItem(..),
|
||||
ChapterIndex(..),
|
||||
InternalPath(..),
|
||||
EpubType(..),
|
||||
BookInfo(..)
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Codec.Archive.Zip (Archive)
|
||||
import qualified Codec.Epub.Data.Metadata as DMeta
|
||||
import qualified Codec.Epub.Data.Manifest as DMan
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Control.Monad.Reader (ReaderT)
|
||||
import Data.String (IsString)
|
||||
import qualified Codec.Epub.Data.Metadata as DMeta
|
||||
import Control.Monad.Except (ExceptT)
|
||||
import Control.Monad.Reader (ReaderT)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- Unified interface for EPub 2 and EPub 3 formats, allows generic programming of both without having to repeat boilerplate
|
||||
class BookInfo a where
|
||||
getTitle :: a -> T.Text
|
||||
getAuthors :: a -> [T.Text]
|
||||
getLandmarks :: a -> [NavItem]
|
||||
getBookPath :: a -> FilePath
|
||||
getSpine :: a -> IO (Either String [(InternalPath, T.Text)])
|
||||
loadChapter :: a -> (InternalPath, T.Text) -> ChapterIndex -> IO (Either String Chapter)
|
||||
|
||||
-- | Position of a chapter within the linear reading order (the spine).
|
||||
newtype ChapterIndex = ChapterIndex Int
|
||||
deriving (Show, Eq, Ord, Num)
|
||||
|
||||
-- | A fully-resolved path to a file inside the EPUB zip.
|
||||
newtype InternalPath = InternalPath FilePath
|
||||
deriving (Show, Eq)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype EpubType = EpubType T.Text
|
||||
deriving (Show,Eq, IsString)
|
||||
-- | A lightweight pointer to a chapter: enough to navigate and label it in the
|
||||
-- sidebar without having rendered its (potentially large) content yet.
|
||||
data ChapterRef = ChapterRef
|
||||
{ refPath :: InternalPath,
|
||||
refTitle :: T.Text,
|
||||
refIndex :: ChapterIndex
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | A chapter rendered to self-contained HTML, ready for WebKit.
|
||||
data Chapter = Chapter
|
||||
{ chapterPath :: InternalPath,
|
||||
chapterTitle :: T.Text,
|
||||
chapterHtml :: T.Text,
|
||||
chapterIndex :: ChapterIndex
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | A node in the (possibly nested) table of contents. @tocTarget@ is the
|
||||
-- resolved chapter path; @tocFragment@ is the optional in-page anchor.
|
||||
data TocEntry = TocEntry
|
||||
{ tocLabel :: T.Text,
|
||||
tocTarget :: InternalPath,
|
||||
tocFragment :: T.Text,
|
||||
tocChildren :: [TocEntry]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | The cheap-to-compute skeleton of a book: reading order + navigation tree.
|
||||
data BookStructure = BookStructure
|
||||
{ structRefs :: [ChapterRef],
|
||||
structToc :: [TocEntry]
|
||||
}
|
||||
|
||||
-- | The UI only ever sees a book through this interface, so it stays
|
||||
-- format-agnostic. The single instance ('EpubEnv') lives in 'EpubParser'.
|
||||
class BookInfo a where
|
||||
bookTitle :: a -> T.Text
|
||||
bookAuthors :: a -> [T.Text]
|
||||
bookFilePath :: a -> FilePath
|
||||
|
||||
-- | Resolve the spine and TOC. Fast: does not render chapter bodies.
|
||||
loadStructure :: a -> IO (Either String BookStructure)
|
||||
|
||||
-- | Render a single chapter's body to self-contained HTML, on demand.
|
||||
renderChapter :: a -> ChapterRef -> IO (Either String Chapter)
|
||||
|
||||
-- | Mutable application state, held in a 'Control.Concurrent.STM.TVar'.
|
||||
-- Rendered chapters accumulate in 'stCache' as the reader visits them.
|
||||
data AppState = AppState
|
||||
{ stRefs :: [ChapterRef],
|
||||
stToc :: [TocEntry],
|
||||
stCache :: M.Map ChapterIndex Chapter,
|
||||
stIndex :: ChapterIndex,
|
||||
stZoom :: Double,
|
||||
stTitle :: T.Text,
|
||||
stBookPath :: FilePath
|
||||
}
|
||||
|
||||
-- | A user request, produced by the keyboard / sidebar and handled centrally.
|
||||
-- 'GoToChapter' carries an optional anchor to scroll to within the chapter.
|
||||
data UserAction
|
||||
= NextChapter
|
||||
| PrevChapter
|
||||
| ZoomIn
|
||||
| ZoomOut
|
||||
| GoToChapter ChapterIndex T.Text
|
||||
|
||||
-- | Parsed EPUB, carried through the parser as a reader environment.
|
||||
data EpubEnv = EpubEnv
|
||||
{ archive :: Archive,
|
||||
opfXml :: String,
|
||||
|
|
@ -52,40 +122,5 @@ data EpubEnv = EpubEnv
|
|||
eVersion :: T.Text
|
||||
}
|
||||
|
||||
data ChapterView = ChapterView
|
||||
{ viewTitle :: T.Text,
|
||||
viewHtml :: T.Text,
|
||||
viewIdx :: ChapterIndex
|
||||
}
|
||||
|
||||
data Chapter = Chapter
|
||||
{ chapterTitle :: T.Text,
|
||||
chapterTags :: T.Text,
|
||||
chapterIdx :: ChapterIndex
|
||||
}
|
||||
|
||||
data AppState = AppState
|
||||
{ cEnv :: EpubEnv,
|
||||
cIdx :: ChapterIndex,
|
||||
zoomlvl :: Double,
|
||||
cSpine :: [(InternalPath, T.Text)],
|
||||
bTitle :: T.Text,
|
||||
cAllChapters :: [Chapter],
|
||||
activeTask :: Maybe (Async ()),
|
||||
taskVersion :: Integer
|
||||
}
|
||||
|
||||
-- | The parser monad: read-only access to the 'EpubEnv', with string errors.
|
||||
type EpubAction a = ReaderT EpubEnv (ExceptT String IO) a
|
||||
|
||||
data UserAction
|
||||
= NextChapter
|
||||
| PrevChapter
|
||||
| ZoomIn
|
||||
| ZoomOut
|
||||
| LoadSpecific ChapterIndex
|
||||
|
||||
data NavItem = NavItem
|
||||
{ navLabel :: T.Text,
|
||||
navPath :: InternalPath,
|
||||
navTypes :: [EpubType]
|
||||
} deriving (Show)
|
||||
|
|
|
|||
338
app/UI.hs
338
app/UI.hs
|
|
@ -1,13 +1,19 @@
|
|||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | The GTK4 / WebKit front end. The book's structure loads in the background;
|
||||
-- chapters are rendered lazily (and cached) the first time they're visited,
|
||||
-- with neighbours preloaded so arrow-key paging feels instant.
|
||||
module UI (runApp) where
|
||||
|
||||
import Control.Concurrent.Async (async)
|
||||
import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVar)
|
||||
import Control.Monad (zipWithM)
|
||||
import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)
|
||||
import Control.Monad (unless, void, when)
|
||||
import Data.GI.Base (AttrOp (..), on)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import EpubParser (EpubEnv (..))
|
||||
import Data.Word (Word32)
|
||||
import EpubParser (EpubEnv) -- brings the `BookInfo EpubEnv` instance into scope
|
||||
import qualified GI.GLib as GLib
|
||||
import qualified GI.GLib.Constants as GLibConst
|
||||
import qualified GI.Gdk as Gdk
|
||||
|
|
@ -16,87 +22,117 @@ import qualified GI.Gtk as Gtk
|
|||
import qualified GI.Gtk.Enums as GtkEnums
|
||||
import qualified GI.WebKit as WebKit
|
||||
import Persistence (loadLastRead, saveLastRead)
|
||||
import State (initialState, prepareView)
|
||||
import Types (AppState (..), ChapterView (..), UserAction (..), ChapterIndex(..), BookInfo (..))
|
||||
import State (initialState)
|
||||
import Types
|
||||
( AppState (..),
|
||||
BookInfo (..),
|
||||
BookStructure (..),
|
||||
Chapter (..),
|
||||
ChapterIndex (..),
|
||||
ChapterRef (..),
|
||||
TocEntry (..),
|
||||
UserAction (..),
|
||||
)
|
||||
|
||||
updateUI :: Gtk.ApplicationWindow -> WebKit.WebView -> ChapterView -> ChapterIndex -> Int -> IO ()
|
||||
updateUI window webView view (ChapterIndex currentIdx) totalCount = do
|
||||
let ttext = T.pack (show (currentIdx + 1)) <> "/ " <> T.pack (show totalCount) <> ": " <> viewTitle view
|
||||
Gtk.set window [#title := ttext]
|
||||
WebKit.webViewLoadHtml webView (viewHtml view) Nothing
|
||||
-- | Widget handles the rest of the module needs.
|
||||
data AppWidgets = AppWidgets
|
||||
{ appWindow :: Gtk.ApplicationWindow,
|
||||
appWebView :: WebKit.WebView,
|
||||
appSidebar :: Gtk.ListBox
|
||||
}
|
||||
|
||||
handleAction :: TVar AppState -> Gtk.ApplicationWindow -> WebKit.WebView -> UserAction -> IO ()
|
||||
handleAction stateTVar window webView action = do
|
||||
st <- atomically $ readTVar stateTVar
|
||||
let totalChapters = length (cAllChapters st)
|
||||
-- | Everything an action handler needs: shared state, widgets, and a way to
|
||||
-- render a chapter on demand (closes over the book).
|
||||
data Ctx = Ctx
|
||||
{ ctxState :: TVar AppState,
|
||||
ctxWidgets :: AppWidgets,
|
||||
ctxRender :: ChapterRef -> IO (Either String Chapter)
|
||||
}
|
||||
|
||||
case action of
|
||||
ZoomIn -> updateZoom stateTVar webView (zoomlvl st + 0.1)
|
||||
ZoomOut -> updateZoom stateTVar webView (max 0.1 (zoomlvl st - 0.1))
|
||||
_ -> do
|
||||
if null (cAllChapters st)
|
||||
then pure ()
|
||||
else do
|
||||
let nextIdx = case action of
|
||||
NextChapter -> cIdx st + 1
|
||||
PrevChapter -> cIdx st - 1
|
||||
LoadSpecific i -> i
|
||||
--------------------------------------------------------------------------------
|
||||
-- Widget tree
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
let safeIdx = max 0 (min (ChapterIndex (totalChapters - 1)) nextIdx)
|
||||
|
||||
case prepareView st safeIdx of
|
||||
Nothing -> pure ()
|
||||
Just view -> do
|
||||
updateUI window webView view safeIdx totalChapters
|
||||
atomically $ modifyTVar stateTVar $ \s -> s {cIdx = viewIdx view}
|
||||
_ <- async $ saveLastRead (bookPath (cEnv st)) (viewIdx view)
|
||||
pure ()
|
||||
|
||||
updateZoom :: TVar AppState -> WebKit.WebView -> Double -> IO ()
|
||||
updateZoom stateTVar webView level = do
|
||||
atomically $ modifyTVar stateTVar $ \s -> s {zoomlvl = level}
|
||||
WebKit.webViewSetZoomLevel webView level
|
||||
|
||||
initAppServices :: (BookInfo a) => a -> TVar AppState -> (UserAction -> IO ()) -> IO ()
|
||||
initAppServices env stateTVar actionHandler = do
|
||||
_ <- async $ do
|
||||
spineResult <- getSpine env
|
||||
case spineResult of
|
||||
Left err -> putStrLn $ "Failed to load spine: " ++ err
|
||||
Right ispine -> do
|
||||
chapterResults <- zipWithM (loadChapter env) ispine (map ChapterIndex [0 ..])
|
||||
|
||||
case sequence chapterResults of
|
||||
Left err -> putStrLn $ "Failed to load chapters: " ++ err
|
||||
Right allChapters -> do
|
||||
let bookTitle = getTitle env
|
||||
atomically $ modifyTVar stateTVar $ \s ->
|
||||
s { cSpine = ispine, cAllChapters = allChapters, bTitle = bookTitle }
|
||||
|
||||
_ <- GLib.idleAdd GLibConst.PRIORITY_DEFAULT $ do
|
||||
maybeSaved <- loadLastRead
|
||||
case maybeSaved of
|
||||
Just (path, idx) | path == getBookPath env -> actionHandler (LoadSpecific idx)
|
||||
_ -> actionHandler (LoadSpecific 0)
|
||||
pure False
|
||||
pure ()
|
||||
pure ()
|
||||
|
||||
activate :: EpubEnv -> Gtk.Application -> IO ()
|
||||
activate env app = do
|
||||
stateTVar <- newTVarIO (initialState env)
|
||||
buildLayout :: Gtk.Application -> IO AppWidgets
|
||||
buildLayout app = do
|
||||
window <- Gtk.applicationWindowNew app
|
||||
webView <- WebKit.webViewNew
|
||||
sidebar <- Gtk.listBoxNew
|
||||
Gtk.listBoxSetSelectionMode sidebar GtkEnums.SelectionModeSingle
|
||||
Gtk.widgetAddCssClass sidebar "toc"
|
||||
|
||||
Gtk.set window [#defaultWidth := 800, #defaultHeight := 600, #child := webView]
|
||||
scrolled <- Gtk.scrolledWindowNew
|
||||
Gtk.scrolledWindowSetChild scrolled (Just sidebar)
|
||||
Gtk.widgetSetSizeRequest scrolled 260 (-1)
|
||||
|
||||
let dispatch = handleAction stateTVar window webView
|
||||
paned <- Gtk.panedNew GtkEnums.OrientationHorizontal
|
||||
Gtk.panedSetStartChild paned (Just scrolled)
|
||||
Gtk.panedSetEndChild paned (Just webView)
|
||||
Gtk.panedSetResizeStartChild paned False
|
||||
|
||||
initAppServices env stateTVar dispatch
|
||||
Gtk.set window [#defaultWidth := 1000, #defaultHeight := 700, #child := paned]
|
||||
applyStyles window
|
||||
pure (AppWidgets window webView sidebar)
|
||||
|
||||
-- | Install the app-wide stylesheet (sidebar rows, selection, headings).
|
||||
applyStyles :: Gtk.ApplicationWindow -> IO ()
|
||||
applyStyles window = do
|
||||
provider <- Gtk.cssProviderNew
|
||||
Gtk.cssProviderLoadFromString provider css
|
||||
disp <- Gtk.widgetGetDisplay window
|
||||
Gtk.styleContextAddProviderForDisplay disp provider appPriority
|
||||
where
|
||||
appPriority = 600 :: Word32
|
||||
css =
|
||||
T.concat
|
||||
[ ".toc { background: transparent; padding: 4px; }",
|
||||
".toc > row { padding: 6px 10px; border-radius: 6px; margin: 1px 4px; }",
|
||||
".toc > row:selected { background-color: rgba(90,130,220,0.35); }",
|
||||
".toc > row:hover { background-color: rgba(128,128,128,0.14); }",
|
||||
"label.toc-top { font-weight: bold; }"
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Sidebar (table of contents)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A displayable sidebar row: nesting depth, label, the chapter it jumps to,
|
||||
-- and an optional in-page anchor.
|
||||
data Row = Row Int T.Text ChapterIndex T.Text
|
||||
|
||||
-- | Flatten the TOC tree into rows, remembering depth (for indentation) and
|
||||
-- the chapter each entry targets. With no TOC, list chapters flatly.
|
||||
displayRows :: [ChapterRef] -> [TocEntry] -> [Row]
|
||||
displayRows refs toc
|
||||
| null toc = [Row 0 (refTitle r) (refIndex r) "" | r <- refs]
|
||||
| otherwise = go 0 toc
|
||||
where
|
||||
pathToIndex = M.fromList [(refPath r, refIndex r) | r <- refs]
|
||||
indexOf target = M.findWithDefault (ChapterIndex 0) target pathToIndex
|
||||
go depth =
|
||||
concatMap
|
||||
(\t -> Row depth (tocLabel t) (indexOf (tocTarget t)) (tocFragment t) : go (depth + 1) (tocChildren t))
|
||||
|
||||
populateSidebar :: Gtk.ListBox -> [Row] -> IO ()
|
||||
populateSidebar sidebar =
|
||||
mapM_ $ \(Row depth label _ _) -> do
|
||||
lbl <- Gtk.labelNew (Just label)
|
||||
Gtk.widgetSetHalign lbl GtkEnums.AlignStart
|
||||
Gtk.labelSetXalign lbl 0
|
||||
Gtk.labelSetWrap lbl True
|
||||
Gtk.widgetSetMarginStart lbl (fromIntegral (depth * 14))
|
||||
when (depth == 0) (Gtk.widgetAddCssClass lbl "toc-top")
|
||||
Gtk.listBoxInsert sidebar lbl (-1)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Events
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
wireEvents :: Ctx -> IO ()
|
||||
wireEvents ctx = do
|
||||
let dispatch = handleAction ctx
|
||||
keyCtrl <- Gtk.eventControllerKeyNew
|
||||
Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
|
||||
|
||||
_ <- on keyCtrl #keyPressed $ \keyval _ _ ->
|
||||
case keyval of
|
||||
Gdk.KEY_Right -> dispatch NextChapter >> pure True
|
||||
|
|
@ -104,14 +140,166 @@ activate env app = do
|
|||
Gdk.KEY_equal -> dispatch ZoomIn >> pure True
|
||||
Gdk.KEY_minus -> dispatch ZoomOut >> pure True
|
||||
_ -> pure False
|
||||
Gtk.widgetAddController (appWindow (ctxWidgets ctx)) keyCtrl
|
||||
|
||||
Gtk.widgetAddController window keyCtrl
|
||||
#present window
|
||||
_ <- on (appSidebar (ctxWidgets ctx)) #rowActivated $ \row -> do
|
||||
i <- Gtk.listBoxRowGetIndex row
|
||||
st <- readTVarIO (ctxState ctx)
|
||||
case drop (fromIntegral i) (displayRows (stRefs st) (stToc st)) of
|
||||
(Row _ _ idx frag : _) -> dispatch (GoToChapter idx frag)
|
||||
[] -> pure ()
|
||||
pure ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Loading
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Load the book's structure off the GTK thread, then populate the sidebar
|
||||
-- and open the first (or last-read) chapter back on the main loop.
|
||||
loadBook :: (BookInfo a) => a -> Ctx -> IO ()
|
||||
loadBook env ctx = void $
|
||||
async $ do
|
||||
result <- loadStructure env
|
||||
case result of
|
||||
Left err -> putStrLn ("Failed to load book: " ++ err)
|
||||
Right (BookStructure refs toc) -> do
|
||||
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stRefs = refs, stToc = toc}
|
||||
postGtk $ do
|
||||
populateSidebar (appSidebar (ctxWidgets ctx)) (displayRows refs toc)
|
||||
saved <- loadLastRead
|
||||
let start = case saved of
|
||||
Just (path, idx) | path == bookFilePath env -> idx
|
||||
_ -> ChapterIndex 0
|
||||
handleAction ctx (GoToChapter start "")
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Navigation + rendering
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
handleAction :: Ctx -> UserAction -> IO ()
|
||||
handleAction ctx action = do
|
||||
st <- readTVarIO (ctxState ctx)
|
||||
case action of
|
||||
ZoomIn -> setZoom ctx (stZoom st + 0.1)
|
||||
ZoomOut -> setZoom ctx (max 0.1 (stZoom st - 0.1))
|
||||
NextChapter -> goto ctx (stIndex st + 1) ""
|
||||
PrevChapter -> goto ctx (stIndex st - 1) ""
|
||||
GoToChapter i frag -> goto ctx i frag
|
||||
|
||||
-- | Move to a chapter (clamped), render it if needed, scroll to @frag@, and
|
||||
-- remember the position. Neighbours are preloaded afterwards.
|
||||
goto :: Ctx -> ChapterIndex -> T.Text -> IO ()
|
||||
goto ctx target frag = do
|
||||
st <- readTVarIO (ctxState ctx)
|
||||
let refs = stRefs st
|
||||
total = length refs
|
||||
when (total > 0) $ do
|
||||
let ChapterIndex t = target
|
||||
i = max 0 (min (total - 1) t)
|
||||
idx = ChapterIndex i
|
||||
ref = refs !! i
|
||||
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stIndex = idx}
|
||||
void $ async (saveLastRead (stBookPath st) idx)
|
||||
case M.lookup idx (stCache st) of
|
||||
Just chapter -> display ctx chapter frag
|
||||
Nothing -> do
|
||||
showLoading ctx ref
|
||||
void $ async $ do
|
||||
rendered <- ctxRender ctx ref
|
||||
case rendered of
|
||||
Left err -> putStrLn ("render failed: " ++ err)
|
||||
Right chapter -> do
|
||||
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stCache = M.insert idx chapter (stCache s)}
|
||||
postGtk $ do
|
||||
cur <- stIndex <$> readTVarIO (ctxState ctx)
|
||||
when (cur == idx) (display ctx chapter frag)
|
||||
preload ctx
|
||||
|
||||
-- | Render the chapters on either side of the current one into the cache.
|
||||
preload :: Ctx -> IO ()
|
||||
preload ctx = do
|
||||
st <- readTVarIO (ctxState ctx)
|
||||
let refs = stRefs st
|
||||
total = length refs
|
||||
ChapterIndex i = stIndex st
|
||||
mapM_ (cacheRef ctx refs) (filter (\n -> n >= 0 && n < total) [i - 1, i + 1])
|
||||
|
||||
cacheRef :: Ctx -> [ChapterRef] -> Int -> IO ()
|
||||
cacheRef ctx refs n = do
|
||||
let idx = ChapterIndex n
|
||||
st <- readTVarIO (ctxState ctx)
|
||||
unless (M.member idx (stCache st)) $
|
||||
void $
|
||||
async $ do
|
||||
rendered <- ctxRender ctx (refs !! n)
|
||||
case rendered of
|
||||
Right chapter -> atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stCache = M.insert idx chapter (stCache s)}
|
||||
Left _ -> pure ()
|
||||
|
||||
display :: Ctx -> Chapter -> T.Text -> IO ()
|
||||
display ctx chapter frag = do
|
||||
setWindowTitle ctx (chapterIndex chapter) (chapterTitle chapter)
|
||||
WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml (chapterHtml chapter) frag) Nothing
|
||||
|
||||
showLoading :: Ctx -> ChapterRef -> IO ()
|
||||
showLoading ctx ref = do
|
||||
setWindowTitle ctx (refIndex ref) (refTitle ref)
|
||||
WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml "<p style=\"opacity:0.5\">Loading…</p>" "") Nothing
|
||||
|
||||
setWindowTitle :: Ctx -> ChapterIndex -> T.Text -> IO ()
|
||||
setWindowTitle ctx (ChapterIndex i) chapter = do
|
||||
st <- readTVarIO (ctxState ctx)
|
||||
let total = length (stRefs st)
|
||||
title = T.pack (show (i + 1)) <> "/" <> T.pack (show total) <> " " <> stTitle st <> " — " <> chapter
|
||||
Gtk.set (appWindow (ctxWidgets ctx)) [#title := title]
|
||||
|
||||
setZoom :: Ctx -> Double -> IO ()
|
||||
setZoom ctx level = do
|
||||
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stZoom = level}
|
||||
WebKit.webViewSetZoomLevel (appWebView (ctxWidgets ctx)) level
|
||||
|
||||
-- | Wrap a chapter's @\<body\>@ fragment in a full, styled HTML document
|
||||
-- (WebKit renders bare fragments unreliably). If @frag@ names an anchor, a
|
||||
-- small script scrolls it into view after load.
|
||||
wrapHtml :: T.Text -> T.Text -> T.Text
|
||||
wrapHtml body frag =
|
||||
T.concat
|
||||
[ "<!DOCTYPE html><html><head><meta charset=\"utf-8\">",
|
||||
"<style>",
|
||||
"body{max-width:42rem;margin:2rem auto;padding:0 1rem;",
|
||||
"font-family:Georgia,serif;line-height:1.6;}",
|
||||
"img{max-width:100%;height:auto;}",
|
||||
"</style></head><body>",
|
||||
body,
|
||||
scrollScript frag,
|
||||
"</body></html>"
|
||||
]
|
||||
where
|
||||
scrollScript "" = ""
|
||||
scrollScript f =
|
||||
let safe = T.filter (\c -> c /= '"' && c /= '\\') f
|
||||
in "<script>var e=document.getElementById(\"" <> safe <> "\");if(e)e.scrollIntoView();</script>"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Entry point
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Schedule an action to run on the GTK main loop.
|
||||
postGtk :: IO () -> IO ()
|
||||
postGtk act = void $ GLib.idleAdd GLibConst.PRIORITY_DEFAULT (act >> pure False)
|
||||
|
||||
activate :: EpubEnv -> Gtk.Application -> IO ()
|
||||
activate env app = do
|
||||
stateTVar <- newTVarIO (initialState (bookTitle env) (bookFilePath env))
|
||||
widgets <- buildLayout app
|
||||
let ctx = Ctx stateTVar widgets (renderChapter env)
|
||||
wireEvents ctx
|
||||
loadBook env ctx
|
||||
#present (appWindow widgets)
|
||||
|
||||
runApp :: EpubEnv -> IO ()
|
||||
runApp env = do
|
||||
app <- Gtk.new Gtk.Application [#applicationId := "com.svitak.reader", #flags := [Gio.ApplicationFlagsDefaultFlags]]
|
||||
_ <- on app #activate (activate env app)
|
||||
_ <- Gio.applicationRun app Nothing -- we're not working with CLI args here, so Nothing can be passed
|
||||
_ <- Gio.applicationRun app Nothing
|
||||
pure ()
|
||||
|
|
|
|||
|
|
@ -88,18 +88,20 @@ test-suite svitak-test
|
|||
type: exitcode-stdio-1.0
|
||||
|
||||
other-modules: EpubParser,
|
||||
Persistence
|
||||
Navigation,
|
||||
Types
|
||||
|
||||
hs-source-dirs: test, app
|
||||
|
||||
build-depends: base,
|
||||
base64-bytestring,
|
||||
bytestring,
|
||||
containers,
|
||||
epub-metadata,
|
||||
filepath,
|
||||
mtl,
|
||||
scalpel,
|
||||
text,
|
||||
zip-archive,
|
||||
directory
|
||||
zip-archive
|
||||
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
98
test/Spec.hs
98
test/Spec.hs
|
|
@ -1,46 +1,74 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Manual dump tool (not automated tests). Opens a real EPUB, prints the
|
||||
-- resolved chapter list (rendering each on demand to show content sizes) and
|
||||
-- the TOC tree:
|
||||
--
|
||||
-- > cabal run svitak-test -- path/to/book.epub
|
||||
module Main (main) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import EpubParser (openEpub)
|
||||
import System.Environment (getArgs)
|
||||
import Control.Monad.Reader (runReaderT)
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
import EpubParser (openEpub, resolveSpine, getChapter, EpubEnv)
|
||||
|
||||
-- Run this as: cabal run svitak-test -- "path/to/book.epub"
|
||||
import Types
|
||||
( BookInfo (..),
|
||||
BookStructure (..),
|
||||
Chapter (..),
|
||||
ChapterIndex (..),
|
||||
ChapterRef (..),
|
||||
InternalPath (..),
|
||||
TocEntry (..),
|
||||
)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
[path] -> runRawDump path
|
||||
_ -> do
|
||||
putStrLn "cabal run svitak-test -- \"path/to/book.epub\""
|
||||
exitFailure
|
||||
args <- getArgs
|
||||
case args of
|
||||
[path] -> run path
|
||||
[path, n] -> dumpOne path (read n)
|
||||
_ -> putStrLn "usage: svitak-test <book.epub> [chapter-index]" >> exitFailure
|
||||
|
||||
runRawDump :: FilePath -> IO ()
|
||||
runRawDump path = do
|
||||
putStrLn $ "Testing EPUB: " ++ path
|
||||
result <- openEpub path
|
||||
case result of
|
||||
Left err -> do
|
||||
putStrLn $ "Failed to open: " ++ err
|
||||
exitFailure
|
||||
Right env -> do
|
||||
spine <- resolveSpineList env
|
||||
putStrLn $ "Spine resolved. Found " ++ show (length spine) ++ " items."
|
||||
mapM_ (dumpChapter env) spine
|
||||
-- | Print the rendered HTML of a single chapter (for debugging image inlining).
|
||||
dumpOne :: FilePath -> Int -> IO ()
|
||||
dumpOne path n = do
|
||||
Right env <- openEpub path
|
||||
Right (BookStructure refs _) <- loadStructure env
|
||||
Right ch <- renderChapter env (refs !! n)
|
||||
putStrLn (T.unpack (T.take 800 (chapterHtml ch)))
|
||||
|
||||
resolveSpineList :: EpubEnv -> IO [FilePath]
|
||||
resolveSpineList env = runReaderT resolveSpine env
|
||||
run :: FilePath -> IO ()
|
||||
run path = do
|
||||
opened <- openEpub path
|
||||
case opened of
|
||||
Left err -> putStrLn ("open failed: " ++ err) >> exitFailure
|
||||
Right env -> do
|
||||
putStrLn ("Title: " ++ T.unpack (bookTitle env))
|
||||
putStrLn ("Authors: " ++ show (map T.unpack (bookAuthors env)))
|
||||
structure <- loadStructure env
|
||||
case structure of
|
||||
Left err -> putStrLn ("structure failed: " ++ err) >> exitFailure
|
||||
Right (BookStructure refs toc) -> do
|
||||
putStrLn ("\n== Chapters (" ++ show (length refs) ++ ") ==")
|
||||
mapM_ (dumpChapter env) refs
|
||||
putStrLn "\n== TOC tree =="
|
||||
mapM_ (dumpToc 0) toc
|
||||
|
||||
dumpChapter :: EpubEnv -> FilePath -> IO ()
|
||||
dumpChapter env filename = do
|
||||
putStrLn $ "\n START OF FILE: " ++ filename
|
||||
putStrLn (replicate 40 '-')
|
||||
dumpChapter :: (BookInfo a) => a -> ChapterRef -> IO ()
|
||||
dumpChapter env ref = do
|
||||
rendered <- renderChapter env ref
|
||||
let size = case rendered of
|
||||
Left err -> "ERR " ++ err
|
||||
Right c -> show (T.length (chapterHtml c)) ++ " chars"
|
||||
putStrLn (" [" ++ show idx ++ "] " ++ T.unpack (refTitle ref) ++ " (" ++ path ++ ", " ++ size ++ ")")
|
||||
where
|
||||
ChapterIndex idx = refIndex ref
|
||||
InternalPath path = refPath ref
|
||||
|
||||
tags <- runReaderT (getChapter filename) env
|
||||
|
||||
mapM_ print tags
|
||||
|
||||
putStrLn (replicate 40 '-')
|
||||
putStrLn $ "END OF FILE: " ++ filename
|
||||
dumpToc :: Int -> TocEntry -> IO ()
|
||||
dumpToc depth t = do
|
||||
putStrLn (replicate (depth * 2) ' ' ++ "- " ++ T.unpack (tocLabel t) ++ " -> " ++ target ++ frag)
|
||||
mapM_ (dumpToc (depth + 1)) (tocChildren t)
|
||||
where
|
||||
InternalPath target = tocTarget t
|
||||
frag = if T.null (tocFragment t) then "" else "#" ++ T.unpack (tocFragment t)
|
||||
|
|
|
|||
Loading…
Reference in a new issue