forked from hashirama/mdict-hs
Merge pull request 'separate pure and IO' (#3) from castelia/mdict-hs:main into main
Reviewed-on: hashirama/mdict-hs#3
This commit is contained in:
commit
7b64430472
2 changed files with 65 additions and 50 deletions
103
MDict.hs
103
MDict.hs
|
|
@ -34,18 +34,22 @@ 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)
|
||||
import Data.List (isInfixOf, intercalate, foldl')
|
||||
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 Wazahs
|
||||
import Data.Bool (Bool)
|
||||
|
||||
-- C-compatible struct
|
||||
data SimpleKeyItem = SimpleKeyItem
|
||||
|
|
@ -237,54 +241,62 @@ listAllKeys dict = do
|
|||
|
||||
-- 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 mdxFile html = do
|
||||
let mddFile = replaceExtension mdxFile ".mdd"
|
||||
mdxDir = takeDirectory mdxFile
|
||||
|
||||
-- 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
|
||||
-- Get all CSS and HTML paths
|
||||
let allPaths = findLocalImages html ++ findcss html
|
||||
|
||||
-- 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
|
||||
return $ replaceSrc [orig] base64 html html
|
||||
|
||||
-- | Helper: convert '/' to '\'
|
||||
slashToBack :: Char -> Char
|
||||
|
|
@ -292,12 +304,15 @@ slashToBack '/' = '\\'
|
|||
slashToBack c = c
|
||||
|
||||
-- | Replace the original src attribute with the base64 string
|
||||
replaceSrc :: String -> String -> String -> String
|
||||
replaceSrc orig base64 html =
|
||||
T.unpack $ T.replace (T.pack $ "src=\"" ++ orig ++ "\"")
|
||||
(T.pack $ "src=\"" ++ base64 ++ "\"")
|
||||
(T.pack html)
|
||||
|
||||
-- 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)
|
||||
|
||||
-- | Lookup the actual media in a .mdd using your MDict bindings
|
||||
lookupMedia :: FilePath -> String -> IO String
|
||||
|
|
@ -313,6 +328,12 @@ 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 =
|
||||
|
|
|
|||
|
|
@ -1,15 +1,9 @@
|
|||
{-# 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.Exit (exitFailure)
|
||||
import Control.Monad
|
||||
import System.FilePath (replaceExtension)
|
||||
import MDict
|
||||
|
||||
import Control.Monad (when)
|
||||
import MDict (lookupInCollection)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
|
@ -21,5 +15,5 @@ main = do
|
|||
let dictDir = args !! 0
|
||||
queryKey = args !! 1
|
||||
|
||||
-- Process all files (lookupInCollection lists files itself)
|
||||
-- Process all files
|
||||
lookupInCollection dictDir queryKey
|
||||
|
|
|
|||
Loading…
Reference in a new issue