diff --git a/app/EpubParser.hs b/app/EpubParser.hs index 1842754..9029487 100644 --- a/app/EpubParser.hs +++ b/app/EpubParser.hs @@ -1,41 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} module EpubParser - ( EpubAction - , EpubEnv(..) - , openEpub - , getOpfPath - , resolveSpine - , getChapter - , getChapterTitle - , Tag(..) - ) where + ( 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.Metadata as DMeta +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), ReaderT, 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 Control.Monad.Reader (ReaderT, MonadReader(ask), liftIO) -import Control.Monad.Except (runExceptT) -import System.FilePath (takeDirectory, (), normalise) -import Data.List (find) -import Text.HTML.TagSoup (parseTags, innerText, Tag(..)) -import Codec.Epub.Parse (getSpine, getMetadata, getManifest) -import qualified Codec.Epub.Data.Metadata as DMeta -import qualified Codec.Epub.Data.Manifest as DMan -import qualified Codec.Epub.Data.Spine as DSpin -import qualified Data.ByteString.Base64 as B64 +import System.FilePath (normalise, takeDirectory, ()) +import Text.HTML.TagSoup (Tag (..), innerText, parseTags) type EpubAction a = ReaderT EpubEnv IO a data EpubEnv = EpubEnv - { archive :: Archive - , opfXml :: String - , baseDir :: FilePath - , bookPath :: FilePath - , eMetadata :: DMeta.Metadata - , eManifest :: DMan.Manifest + { archive :: Archive, + opfXml :: String, + baseDir :: FilePath, + bookPath :: FilePath, + eMetadata :: DMeta.Metadata, + eManifest :: DMan.Manifest } openEpub :: FilePath -> IO (Either String EpubEnv) @@ -52,20 +52,22 @@ openEpub path = do let xml = T.unpack $ TE.decodeUtf8 $ B.toStrict $ fromEntry entry metaResult <- runExceptT $ getMetadata xml - manResult <- runExceptT $ getManifest 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 - } + (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 = @@ -76,7 +78,7 @@ getOpfPath arch = getRootPath :: [Tag String] -> Maybe FilePath getRootPath [] = Nothing getRootPath (TagOpen "rootfile" attrs : _) = lookup "full-path" attrs -getRootPath (_:xs) = getRootPath xs +getRootPath (_ : xs) = getRootPath xs resolveSpine :: EpubAction [FilePath] resolveSpine = do @@ -88,7 +90,7 @@ resolveSpine = do 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 [p | ref <- refs, let ident = DSpin.siIdRef ref, Just p <- [lookupHref ident]] _ -> pure [] getChapter :: FilePath -> EpubAction [Tag T.Text] @@ -97,7 +99,7 @@ getChapter filename = do let full = normalise (baseDir env filename) case findEntryByPath full (archive env) of Nothing -> pure [] - Just e -> do + Just e -> do let rawTags = parseTags . TE.decodeUtf8 . B.toStrict $ fromEntry e pure (filterJunk (embedImages env rawTags)) @@ -105,48 +107,47 @@ 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" + Nothing -> "image/jpeg" -- Replace img tags with base64 embedImages :: EpubEnv -> [Tag T.Text] -> [Tag T.Text] -embedImages env = map processTag +embedImages env = map processTag where processTag (TagOpen "img" attrs) = TagOpen "img" (map replaceSrc attrs) - processTag other = other + 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) + | 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 + 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 +filterJunk = go where go [] = [] - go (TagOpen name _ : xs) | name `elem` ["script", "style", "head", "link", "meta"] = -- these are elems we want to filter out - go (dropUntilClose name xs) - go (x:xs) = x : go xs + 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" +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 + ishding (TagOpen n _) = n `elem` ["h1", "h2", "h3"] + ishding _ = False + isclose n (TagClose n') = n == n' + isclose _ _ = False diff --git a/app/Main.hs b/app/Main.hs index c6dc870..6b861b1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,7 @@ module Main where -import System.Environment (getArgs) import EpubParser (openEpub) +import System.Environment (getArgs) import UI (runApp) main :: IO () diff --git a/app/Persistence.hs b/app/Persistence.hs index 3007ab8..7354dbb 100644 --- a/app/Persistence.hs +++ b/app/Persistence.hs @@ -1,26 +1,27 @@ -module Persistence - ( saveLastRead - , loadLastRead - ) where +module Persistence + ( saveLastRead, + loadLastRead, + ) +where -import System.Directory (getXdgDirectory, XdgDirectory(XdgData), createDirectoryIfMissing) -import System.FilePath (()) +import Control.Exception (SomeException, try) import qualified Data.Text as T import qualified Data.Text.IO as TIO -import Control.Exception (try, SomeException) +import System.Directory (XdgDirectory (XdgData), createDirectoryIfMissing, getXdgDirectory) +import System.FilePath (()) import Text.Read (readMaybe) saveLastRead :: FilePath -> Int -> IO () saveLastRead bPath chapterIdx = do - dataDir <- getXdgDirectory XdgData "svitak" - createDirectoryIfMissing True dataDir - - let configFile = dataDir "last_read.txt" - -- Line 1 = Path, Line 2 = Index - let content = T.pack bPath <> T.pack "\n" <> T.pack (show chapterIdx) - - TIO.writeFile configFile content - putStrLn $ "Progress saved to: " ++ configFile + dataDir <- getXdgDirectory XdgData "svitak" + createDirectoryIfMissing True dataDir + + let configFile = dataDir "last_read.txt" + -- Line 1 = Path, Line 2 = Index + let content = T.pack bPath <> T.pack "\n" <> T.pack (show chapterIdx) + + TIO.writeFile configFile content + putStrLn $ "Progress saved to: " ++ configFile loadLastRead :: IO (Maybe (FilePath, Int)) loadLastRead = do @@ -28,13 +29,13 @@ loadLastRead = do let configFile = dataDir "last_read.txt" result <- try (TIO.readFile configFile) :: IO (Either SomeException T.Text) - + case result of Left _ -> pure Nothing Right content -> do let linesOfFile = T.lines content case linesOfFile of - [path, idxStr] - | Just idx <- readMaybe (T.unpack idxStr) -> + [path, idxStr] + | Just idx <- readMaybe (T.unpack idxStr) -> pure $ Just (T.unpack path, idx) _ -> pure Nothing diff --git a/app/State.hs b/app/State.hs index 2bae66b..1563a40 100644 --- a/app/State.hs +++ b/app/State.hs @@ -2,10 +2,10 @@ module State where -import qualified Data.Text as T -import Text.HTML.TagSoup (Tag, renderTags) import Control.Concurrent.Async (Async) +import qualified Data.Text as T import EpubParser (EpubEnv, getChapterTitle) +import Text.HTML.TagSoup (Tag, renderTags) data ChapterView = ChapterView { viewTitle :: T.Text, diff --git a/app/UI.hs b/app/UI.hs index 53ce46b..8871077 100644 --- a/app/UI.hs +++ b/app/UI.hs @@ -1,99 +1,99 @@ -{-# LANGUAGE OverloadedStrings, OverloadedLabels #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} module UI (runApp) where -import qualified GI.Gtk as Gtk -import qualified GI.Gdk as Gdk -import qualified GI.Gio as Gio +import Codec.Epub.Data.Metadata (metaTitles, titleText, titleType) +import Control.Concurrent.Async (async) +import Control.Concurrent.STM (atomically, modifyTVar, newTVarIO, readTVar) +import Control.Monad.Reader (runReaderT) +import Data.GI.Base (AttrOp (..)) +import Data.List (find) +import qualified Data.Text as T +import EpubParser (EpubEnv (..), getChapter, resolveSpine) import qualified GI.GLib as GLib import qualified GI.GLib.Constants as GLibConst -import qualified GI.WebKit as WebKit +import qualified GI.Gdk as Gdk +import qualified GI.Gio as Gio +import qualified GI.Gtk as Gtk import qualified GI.Gtk.Enums as GtkEnums -import qualified Data.Text as T - -import Data.List (find) -import Data.GI.Base (AttrOp(..)) -import Control.Monad.Reader (runReaderT) -import Control.Concurrent.STM (newTVarIO, readTVar, atomically, modifyTVar) -import Control.Concurrent.Async (async) -import Codec.Epub.Data.Metadata (metaTitles, titleType, titleText) -import EpubParser (EpubEnv(..), resolveSpine, getChapter) -import Persistence (saveLastRead, loadLastRead) -import State (AppState(..), ChapterView(..), initialState, prepareView) +import qualified GI.WebKit as WebKit +import Persistence (loadLastRead, saveLastRead) +import State (AppState (..), ChapterView (..), initialState, prepareView) runApp :: EpubEnv -> IO () runApp env' = do - app <- Gtk.applicationNew (Just "com.svitak.reader.v2") [] + app <- Gtk.applicationNew (Just "com.svitak.reader.v2") [] - _ <- Gtk.on app #activate $ do + _ <- Gtk.on app #activate $ do + stateTVar <- newTVarIO (initialState env') - stateTVar <- newTVarIO (initialState env') + window <- Gtk.applicationWindowNew app + webView <- WebKit.webViewNew + Gtk.set window [#defaultWidth := 800, #defaultHeight := 600, #child := webView] - window <- Gtk.applicationWindowNew app - webView <- WebKit.webViewNew - Gtk.set window [ #defaultWidth := 800, #defaultHeight := 600, #child := webView ] + -- load all chapters on another thread + let loadChapter index = do + st <- atomically $ readTVar stateTVar + case prepareView st index of + Nothing -> pure () + Just view -> do + Gtk.set window [#title := viewTitle view] + WebKit.webViewLoadHtml webView (viewHtml view) Nothing - -- load all chapters on another thread - let loadChapter index = do - st <- atomically $ readTVar stateTVar - case prepareView st index of - Nothing -> pure () - Just view -> do - Gtk.set window [ #title := viewTitle view ] - WebKit.webViewLoadHtml webView (viewHtml view) Nothing + atomically $ modifyTVar stateTVar $ \s -> s {cIdx = viewIdx view} + _ <- async $ saveLastRead (bookPath env') (viewIdx view) + pure () - atomically $ modifyTVar stateTVar $ \s -> s { cIdx = viewIdx view} - _ <- async $ saveLastRead (bookPath env') (viewIdx view) - pure () + -- keyboard handling + keyCtrl <- Gtk.eventControllerKeyNew + Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture - -- keyboard handling - keyCtrl <- Gtk.eventControllerKeyNew - Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture - - _ <- Gtk.on keyCtrl #keyPressed $ \keyval _ _ -> do - stNow <- atomically $ readTVar stateTVar - case keyval of - Gdk.KEY_Right -> loadChapter (cIdx stNow + 1) >> pure True - Gdk.KEY_Left -> loadChapter (cIdx stNow - 1) >> pure True - Gdk.KEY_equal -> do - let newZ = zoomlvl stNow + 0.1 - atomically $ modifyTVar stateTVar $ \s -> s { zoomlvl = newZ } - WebKit.webViewSetZoomLevel webView newZ - pure True - Gdk.KEY_minus -> do - let newZ = max 0.1 (zoomlvl stNow - 0.1) - atomically $ modifyTVar stateTVar $ \s -> s { zoomlvl = newZ } - WebKit.webViewSetZoomLevel webView newZ - pure True - _ -> pure False + _ <- Gtk.on keyCtrl #keyPressed $ \keyval _ _ -> do + stNow <- atomically $ readTVar stateTVar + case keyval of + Gdk.KEY_Right -> loadChapter (cIdx stNow + 1) >> pure True + Gdk.KEY_Left -> loadChapter (cIdx stNow - 1) >> pure True + Gdk.KEY_equal -> do + let newZ = zoomlvl stNow + 0.1 + atomically $ modifyTVar stateTVar $ \s -> s {zoomlvl = newZ} + WebKit.webViewSetZoomLevel webView newZ + pure True + Gdk.KEY_minus -> do + let newZ = max 0.1 (zoomlvl stNow - 0.1) + atomically $ modifyTVar stateTVar $ \s -> s {zoomlvl = newZ} + WebKit.webViewSetZoomLevel webView newZ + pure True + _ -> pure False - Gtk.widgetAddController window keyCtrl - #present window + Gtk.widgetAddController window keyCtrl + #present window - -- start eager parse - _ <- async $ do - ispine <- runReaderT resolveSpine env' - allChapters <- runReaderT (mapM getChapter ispine) env' - - let titles = metaTitles (eMetadata env') - let rawT = case find (\t -> titleType t == Just "main") titles of - Just t -> titleText t - Nothing -> if null titles then "Unknown" else titleText (head titles) + -- start eager parse + _ <- async $ do + ispine <- runReaderT resolveSpine env' + allChapters <- runReaderT (mapM getChapter ispine) env' - atomically $ modifyTVar stateTVar $ \s -> s - { cSpine = ispine - , cAllChapters = allChapters - , bTitle = T.pack rawT - } + let titles = metaTitles (eMetadata env') + let rawT = case find (\t -> titleType t == Just "main") titles of + Just t -> titleText t + Nothing -> if null titles then "Unknown" else titleText (head titles) - _ <- GLib.idleAdd GLibConst.PRIORITY_DEFAULT $ do - maybeSaved <- loadLastRead - case maybeSaved of - Just (path, idx) | path == bookPath env' -> loadChapter idx - _ -> loadChapter 0 - pure False - pure () - pure () + atomically $ modifyTVar stateTVar $ \s -> + s + { cSpine = ispine, + cAllChapters = allChapters, + bTitle = T.pack rawT + } - _ <- Gio.applicationRun app Nothing + _ <- GLib.idleAdd GLibConst.PRIORITY_DEFAULT $ do + maybeSaved <- loadLastRead + case maybeSaved of + Just (path, idx) | path == bookPath env' -> loadChapter idx + _ -> loadChapter 0 + pure False + pure () pure () + + _ <- Gio.applicationRun app Nothing + pure ()