hashirama/mdict-hs
hashirama/mdict-hs
Watch
1
0
Fork
You've already forked mdict-hs
 1
Code Issues 1 Pull requests Projects Releases Wiki Activity Actions

Compare commits

base: hashirama:stable
Branches Tags
hashirama:main
hashirama:stable
..
compare: hashirama:main
Branches Tags
hashirama:stable
hashirama:main
1 changed files with 64 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

119
MDict.hs
View file

@ -34,27 +34,22 @@ import qualified Data.ByteString.Char8 as BSC
import Data.Word (Word64) import Data.Word (Word64)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified Data.Conduit.Combinators as CC
import Data.Conduit
import Conduit
import Data.Char (toLower) import Data.Char (toLower)
import System.FilePath (takeExtension) import System.FilePath (takeExtension)
import Text.HTML.Scalpel import Text.HTML.Scalpel
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List (isInfixOf, intercalate) import Data.List (isInfixOf, intercalate, foldl')
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath ((</>), takeDirectory) import System.FilePath ((</>), takeDirectory)
import Control.Monad import Control.Monad
import Control.Applicative
import System.FilePath (replaceExtension) import System.FilePath (replaceExtension)
import Control.DeepSeq (NFData, deepseq) import Control.DeepSeq (NFData, deepseq)
import qualified Data.Conduit.Combinators as CC import Data.Bool (Bool)
import Data.Conduit
import Conduit
listFiles :: FilePath -> IO [FilePath]
listFiles dir = runConduitRes $
CC.sourceDirectoryDeep False dir
.| filterC (\fp -> takeExtension fp == ".mdx")
.| CC.sinkList
-- C-compatible struct -- C-compatible struct
data SimpleKeyItem = SimpleKeyItem data SimpleKeyItem = SimpleKeyItem
@ -246,54 +241,62 @@ listAllKeys dict = do
-- Media related functions: -- Media related functions:
-- | Replace all local <img> sources with base64 content from .mdd findLocalImages :: String -> [String]
findLocalImages html =
let urlsRaw = scrapeStringLike html $ chroots "img" $ attr "src" anySelector
allUrls = fromMaybe [] urlsRaw
in filter isLocal allUrls
findcss :: String -> [String]
findcss html =
let urlsRaw = scrapeStringLike html $ chroots "link" $ liftA2 (,) (attr "rel" anySelector) (attr "href" anySelector) >>= \(rel, href) -> guard (rel == "stylesheet") >> pure href
allUrls = fromMaybe [] urlsRaw
in filter isLocal allUrls
isLocal :: String -> Bool
isLocal url = not ("://" `isInfixOf` url)
-- Takes a list of paths, looks them up in the MDD, returns pairs of (Path, Base64)
fetchResources :: FilePath -> [String] -> IO [(String, String)]
fetchResources mddFile paths = do
mapM (\path -> do
let query = "\\" ++ map slashToBack path
base64 <- lookupMedia mddFile query
return (path, base64)
) paths
-- Replaces every occurrence of 'path' with 'base64' in the HTML
injectResources :: String -> [(String, String)] -> String
injectResources =
foldl' applyReplacement
where
applyReplacement currentHtml (path, base64) =
if null base64
then currentHtml
else replaceSrc ["src", "href"] path base64 currentHtml
replaceMedia :: FilePath -> String -> IO String replaceMedia :: FilePath -> String -> IO String
replaceMedia mdxFile html = do replaceMedia mdxFile html = do
let mddFile = replaceExtension mdxFile ".mdd" let mddFile = replaceExtension mdxFile ".mdd"
mdxDir = takeDirectory mdxFile mdxDir = takeDirectory mdxFile
-- Phase 1: Replace <img src="..."> media -- Get all CSS and HTML paths
let urlsRaw = scrapeStringLike html $ chroots "img" $ attr "src" anySelector let allPaths = findLocalImages html ++ findcss html
urls = fromMaybe [] urlsRaw
localPaths = filter (not . isInfixOf "://") urls
html' <- foldM (replaceOne mddFile) html localPaths
-- Phase 2: Handle CSS
let cssRaw = scrapeStringLike html' $ chroots "link" $ do
rel <- attr "rel" anySelector
href <- attr "href" anySelector
if rel == "stylesheet" then return href else fail "not css"
cssFiles = fromMaybe [] cssRaw
localCssFiles = filter (not . isInfixOf "://") cssFiles
-- Lookup each CSS in the dictionary or read from local file -- Lookup each CSS in the dictionary or read from local file
cssBlocks <- mapM (\css -> do
let localPath = mdxDir </> css
exists <- doesFileExist localPath
if exists
then readFile localPath
else lookupMedia mddFile css
) localCssFiles
let cssTag = concatMap (\c -> if null c then "" else "<style>" ++ c ++ "</style>") cssBlocks
-- Inject all CSS into <head> if exists, otherwise prepend
let maybeHead = scrapeStringLike html' (chroot "head" (return ()))
htmlWithCss =
if maybeHead /= Nothing
then intercalate ("<head>" ++ cssTag) (splitOn "<head>" html')
else cssTag ++ html'
return htmlWithCss
resources <- fetchResources mddFile allPaths
pure $ injectResources html resources
-- | Replace a single <img> src with base64 content -- | Replace a single <img> src with base64 content
replaceOne :: FilePath -> String -> String -> IO String replaceOne :: FilePath -> String -> String -> IO String
replaceOne mddFile html orig = do replaceOne mddFile html orig = do
let lookupQuery = "\\" ++ map slashToBack orig let lookupQuery = "\\" ++ map slashToBack orig
base64 <- lookupMedia mddFile lookupQuery base64 <- lookupMedia mddFile lookupQuery
return $ replaceSrc orig base64 html return $ replaceSrc [orig] base64 html html
-- | Helper: convert '/' to '\' -- | Helper: convert '/' to '\'
slashToBack :: Char -> Char slashToBack :: Char -> Char
@ -301,12 +304,15 @@ slashToBack '/' = '\\'
slashToBack c = c slashToBack c = c
-- | Replace the original src attribute with the base64 string -- | Replace the original src attribute with the base64 string
replaceSrc :: String -> String -> String -> String -- attrs is the list, e.g., ["src", "href"]
replaceSrc orig base64 html = replaceSrc :: [String] -> String -> String -> String -> String
T.unpack $ T.replace (T.pack $ "src=\"" ++ orig ++ "\"") replaceSrc attrs orig base64 html =
(T.pack $ "src=\"" ++ base64 ++ "\"") foldl' uAttr html attrs
(T.pack html) where
uAttr chtml attr =
T.unpack $ T.replace (T.pack $ attr ++ "=\"" ++ orig ++ "\"" )
(T.pack $ attr ++ "=\"" ++ base64 ++ "\"" )
(T.pack chtml)
-- | Lookup the actual media in a .mdd using your MDict bindings -- | Lookup the actual media in a .mdd using your MDict bindings
lookupMedia :: FilePath -> String -> IO String lookupMedia :: FilePath -> String -> IO String
@ -322,6 +328,12 @@ lookupMedia mddFile query = do
-- putStrLn $ "DEBUG: Found media for " ++ query -- putStrLn $ "DEBUG: Found media for " ++ query
return base64 return base64
listFiles :: FilePath -> IO [FilePath]
listFiles dir = runConduitRes $
CC.sourceDirectoryDeep False dir
.| filterC (\fp -> takeExtension fp == ".mdx")
.| CC.sinkList
processDictionary :: FilePath -> String -> IO (Either String String) processDictionary :: FilePath -> String -> IO (Either String String)
processDictionary dictFile queryKey = processDictionary dictFile queryKey =
@ -339,10 +351,7 @@ lookupInCollection dir queryKey = do
files <- listFiles dir files <- listFiles dir
forM_ files $ \file -> do forM_ files $ \file -> do
putStrLn $ "Processing: " ++ file putStrLn $ "Processing: " ++ file
res <- processDictionary file queryKey html <- lookupWordAtomic file queryKey -- needs to combine with replaceMedia
html <- case res of
Left err -> error $ "Error: " ++ err
Right h -> return h
putStrLn html putStrLn html
putStrLn "-----" putStrLn "-----"