marko/mdict-hs
Watch
1
0
Fork
You've already forked mdict-hs
 0
forked from hashirama/mdict-hs
Code Pull requests Activity

Merge pull request 'separate pure and IO' (#3) from castelia/mdict-hs:main into main

Browse source 
Reviewed-on: hashirama/mdict-hs#3
This commit is contained in:
千住柱間 2026-01-20 02:11:15 +00:00
commit 7b64430472
2 changed files with 65 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

103
MDict.hs
View file

@ -34,18 +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 Wazahs import Data.Bool (Bool)
-- C-compatible struct -- C-compatible struct
data SimpleKeyItem = SimpleKeyItem data SimpleKeyItem = SimpleKeyItem
@ -237,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
@ -292,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
@ -313,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 =

12
cli-example/Main.hs
View file

@ -1,15 +1,9 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
import Text.HTML.Scalpel
import Data.Maybe (fromMaybe)
import Data.List (isInfixOf)
import qualified Data.Text as T
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import Control.Monad import Control.Monad (when)
import System.FilePath (replaceExtension) import MDict (lookupInCollection)
import MDict
main :: IO () main :: IO ()
main = do main = do
@ -21,5 +15,5 @@ main = do
let dictDir = args !! 0 let dictDir = args !! 0
queryKey = args !! 1 queryKey = args !! 1
-- Process all files (lookupInCollection lists files itself) -- Process all files
lookupInCollection dictDir queryKey lookupInCollection dictDir queryKey