Update MDict.hs

2026-01-20 03:43:49 +00:00
1 changed files with 55 additions and 64 deletions
--- a/MDict.hs
+++ b/MDict.hs
@ -34,22 +34,27 @@ import qualified Data.ByteString.Char8 as BSC
 import Data.Word (Word64)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
-import qualified Data.Conduit.Combinators as CC
-import Data.Conduit
-import Conduit
 import Data.Char (toLower)
 import System.FilePath (takeExtension)
 import Text.HTML.Scalpel
 import Data.Maybe (fromMaybe)
-import Data.List (isInfixOf, intercalate, foldl')
+import Data.List (isInfixOf, intercalate)
 import Data.List.Split (splitOn)
 import System.Directory (doesFileExist)
 import System.FilePath ((</>), takeDirectory)
 import Control.Monad
-import Control.Applicative
 import System.FilePath (replaceExtension)
 import Control.DeepSeq (NFData, deepseq)
-import Data.Bool (Bool)
+import qualified Data.Conduit.Combinators as CC
+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
 data SimpleKeyItem = SimpleKeyItem
@ -241,62 +246,54 @@ listAllKeys dict = do

 -- Media related functions:

-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
-
+-- | Replace all local <img> sources with base64 content from .mdd
 replaceMedia :: FilePath -> String -> IO String
 replaceMedia mdxFile html = do
    let mddFile = replaceExtension mdxFile ".mdd"
        mdxDir  = takeDirectory mdxFile

-    -- Get all CSS and HTML paths 
-    let allPaths = findLocalImages html ++ findcss html
+    -- Phase 1: Replace <img src="..."> media
+    let urlsRaw = scrapeStringLike html $ chroots "img" $ attr "src" anySelector
+        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
+    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
 replaceOne :: FilePath -> String -> String -> IO String
 replaceOne mddFile html orig = do
    let lookupQuery = "\\" ++ map slashToBack orig
    base64 <- lookupMedia mddFile lookupQuery
-    return $ replaceSrc [orig] base64 html html
+    return $ replaceSrc orig base64 html

 -- | Helper: convert '/' to '\'
 slashToBack :: Char -> Char
@ -304,15 +301,12 @@ slashToBack '/' = '\\'
 slashToBack c   = c

 -- | Replace the original src attribute with the base64 string
-- attrs is the list, e.g., ["src", "href"]
-replaceSrc :: [String] -> String -> String -> String -> String
-replaceSrc attrs orig base64 html =
-  foldl' uAttr html attrs
-  where
-    uAttr chtml attr =
-      T.unpack $ T.replace (T.pack $ attr ++ "=\"" ++ orig ++ "\"" )
-                           (T.pack $ attr ++ "=\"" ++ base64 ++ "\"" )
-                           (T.pack chtml)
+replaceSrc :: String -> String -> String -> String
+replaceSrc orig base64 html =
+    T.unpack $ T.replace (T.pack $ "src=\"" ++ orig ++ "\"")
+                         (T.pack $ "src=\"" ++ base64 ++ "\"")
+                         (T.pack html)
+

 -- | Lookup the actual media in a .mdd using your MDict bindings
 lookupMedia :: FilePath -> String -> IO String
@ -328,12 +322,6 @@ lookupMedia mddFile query = do
              --  putStrLn $ "DEBUG: Found media for " ++ query
                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 dictFile queryKey =
@ -351,7 +339,10 @@ lookupInCollection dir queryKey = do
    files <- listFiles dir
    forM_ files $ \file -> do
        putStrLn $ "Processing: " ++ file
-        html <- lookupWordAtomic file queryKey -- needs to combine with replaceMedia
+        res <- processDictionary file queryKey
+        html <- case res of
+            Left err -> error $ "Error: " ++ err
+            Right h  -> return h
+
        putStrLn html
        putStrLn "-----"
-