forked from hashirama/mdict-hs
357 lines
12 KiB
Haskell
357 lines
12 KiB
Haskell
-- Copyright © 2025 Hashirama Senju
|
|
{-# LANGUAGE ForeignFunctionInterface #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module MDict (
|
|
MDict,
|
|
isMDDFile,
|
|
MDictType(..),
|
|
withMDict,
|
|
lookupWord,
|
|
locateWord,
|
|
parseDefinition,
|
|
getKeys,
|
|
getFileType,
|
|
mimeDetect,
|
|
destroyDict,
|
|
listAllKeys,
|
|
replaceMedia,
|
|
lookupInCollection,
|
|
processDictionary
|
|
) where
|
|
|
|
import Foreign
|
|
import Foreign.C
|
|
import Foreign.C.String
|
|
import Foreign.C.Types
|
|
import Foreign.Ptr (Ptr, FunPtr, nullPtr, castFunPtr)
|
|
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
|
|
import Control.Exception (bracket, throwIO)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Internal as BSI
|
|
import qualified Data.ByteString.Base64 as B64
|
|
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.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)
|
|
|
|
-- C-compatible struct
|
|
data SimpleKeyItem = SimpleKeyItem
|
|
{ recordStart :: Word64
|
|
, keyWordPtr :: CString
|
|
}
|
|
|
|
instance Storable SimpleKeyItem where
|
|
sizeOf _ = 16
|
|
alignment _ = 8
|
|
peek ptr = SimpleKeyItem <$> peekByteOff ptr 0 <*> peekByteOff ptr 8
|
|
poke ptr (SimpleKeyItem rs kw) = pokeByteOff ptr 0 rs >> pokeByteOff ptr 8 kw
|
|
|
|
-- Dictionary handle
|
|
newtype MDict = MDict (ForeignPtr ())
|
|
|
|
-- Dictionary type
|
|
data MDictType = MDX | MDD deriving (Show, Eq, Enum)
|
|
|
|
isMDDFile :: FilePath -> Bool
|
|
isMDDFile path = map toLower (takeExtension path) == ".mdd"
|
|
|
|
|
|
-- FFI imports
|
|
foreign import ccall "mdict_init" c_mdict_init :: CString -> IO (Ptr ())
|
|
foreign import ccall "mdict_destory" c_mdict_destroy :: Ptr () -> IO CInt
|
|
foreign import ccall "&mdict_destory" raw_mdict_destroy_finalizer :: FunPtr (Ptr () -> IO CInt)
|
|
foreign import ccall "mdict_lookup" c_mdict_lookup :: Ptr () -> CString -> Ptr (Ptr CChar) -> IO ()
|
|
foreign import ccall "mdict_atomic_lookup" c_mdict_atomic_lookup :: CString -> CString -> IO CString
|
|
foreign import ccall "mdict_locate" c_mdict_locate :: Ptr () -> CString -> Ptr (Ptr CChar) -> CInt -> IO ()
|
|
foreign import ccall "mdict_parse_definition" c_mdict_parse_definition :: Ptr () -> CString -> Word64 -> Ptr (Ptr CChar) -> IO ()
|
|
foreign import ccall "mdict_keylist" c_mdict_keylist :: Ptr () -> Ptr Word64 -> IO (Ptr (Ptr SimpleKeyItem))
|
|
foreign import ccall "free_simple_key_list" c_free_simple_key_list :: Ptr (Ptr SimpleKeyItem) -> Word64 -> IO CInt
|
|
foreign import ccall "mdict_filetype" c_mdict_filetype :: Ptr () -> IO CInt
|
|
foreign import ccall "mdict_suggest" c_mdict_suggest :: Ptr () -> CString -> Ptr (Ptr (Ptr CChar)) -> CInt -> IO ()
|
|
foreign import ccall "mdict_stem" c_mdict_stem :: Ptr () -> CString -> Ptr (Ptr (Ptr CChar)) -> CInt -> IO ()
|
|
foreign import ccall unsafe "string.h strlen" c_strlen :: CString -> IO CSize
|
|
|
|
foreign import ccall unsafe "c_mime_detect"
|
|
c_mime_detect :: CString -> IO CString
|
|
|
|
-- Convert a Haskell String to CString, call the C function, get back a Haskell String
|
|
mimeDetect :: String -> IO String
|
|
mimeDetect filename =
|
|
withCString filename $ \cstr -> do
|
|
result <- c_mime_detect cstr
|
|
peekCString result
|
|
|
|
|
|
-- Define a Haskell version of the enum
|
|
data MDictEncoding = MDBase64 | MDHex
|
|
|
|
-- Convert to CInt for FFI
|
|
encodeToCInt :: MDictEncoding -> CInt
|
|
encodeToCInt MDBase64 = 0
|
|
encodeToCInt MDHex = 1
|
|
|
|
|
|
-- | Destroy a dictionary
|
|
destroyDict :: MDict -> IO ()
|
|
destroyDict (MDict fptr) = withForeignPtr fptr $ \ptr -> do
|
|
_ <- c_mdict_destroy ptr
|
|
return ()
|
|
|
|
|
|
-- Cast finalizer to expected type for newForeignPtr
|
|
castFinalizer :: FunPtr (Ptr () -> IO CInt) -> FinalizerPtr a
|
|
castFinalizer = castFunPtr
|
|
|
|
-- Safe dictionary initialization
|
|
withMDict :: NFData a => FilePath -> (MDict -> IO a) -> IO a
|
|
withMDict path action = withCString path $ \cpath -> do
|
|
rawPtr <- c_mdict_init cpath
|
|
when (rawPtr == nullPtr) $
|
|
throwIO (userError "Failed to initialize MDict")
|
|
|
|
fp <- newForeignPtr (castFinalizer raw_mdict_destroy_finalizer) rawPtr
|
|
let dict = MDict fp
|
|
|
|
result <- action dict
|
|
result `deepseq` return result
|
|
|
|
lookupWordAtomic :: FilePath -> String -> IO String
|
|
lookupWordAtomic dictFile key =
|
|
withCString dictFile $ \cfile ->
|
|
withCString key $ \ckey -> do
|
|
cstr <- c_mdict_atomic_lookup cfile ckey
|
|
result <- peekCString cstr
|
|
free cstr
|
|
return result
|
|
|
|
|
|
-- Lookup
|
|
lookupWord :: MDict -> String -> String -> IO (Either String String)
|
|
lookupWord (MDict fptr) dictFile word =
|
|
withForeignPtr fptr $ \ptr ->
|
|
withCString word $ \cword ->
|
|
alloca $ \resultPtr -> do
|
|
let isMDD = isMDDFile dictFile
|
|
if not isMDD
|
|
then c_mdict_lookup ptr cword resultPtr
|
|
else c_mdict_locate ptr cword resultPtr 0 -- force base64
|
|
|
|
result <- peek resultPtr
|
|
if result == nullPtr
|
|
then return $ Left "Word not found"
|
|
else do
|
|
str <- peekCString (castPtr result)
|
|
-- MIME detection can be applied here if desired
|
|
mime <- mimeDetect word
|
|
let finalStr =
|
|
if mime /= "application/octet-stream"
|
|
then "data:" ++ mime ++ ";base64," ++ str
|
|
else str
|
|
return $ Right finalStr
|
|
|
|
|
|
|
|
-- Locate
|
|
locateWord :: MDict -> String -> Bool -> IO (Either String BS.ByteString)
|
|
locateWord (MDict fptr) word hexOutput =
|
|
withForeignPtr fptr $ \ptr ->
|
|
withCString word $ \cword ->
|
|
alloca $ \resultPtr -> do
|
|
let enc = if hexOutput then 1 else 0 -- MDD_ENCODING_HEX or BASE64
|
|
c_mdict_locate ptr cword resultPtr (fromIntegral enc)
|
|
result <- peek resultPtr
|
|
if result == nullPtr
|
|
then return $ Left "No result"
|
|
else do
|
|
len <- c_strlen result
|
|
bs <- BSI.create (fromIntegral len) $ \p ->
|
|
BSI.memcpy p (castPtr result) (fromIntegral len)
|
|
return $ Right bs
|
|
|
|
|
|
-- Parse definition
|
|
parseDefinition :: MDict -> String -> Word64 -> IO (Either String BS.ByteString)
|
|
parseDefinition (MDict fptr) word start = withForeignPtr fptr $ \ptr ->
|
|
withCString word $ \cword ->
|
|
alloca $ \resultPtr -> do
|
|
c_mdict_parse_definition ptr cword start resultPtr
|
|
result <- peek resultPtr
|
|
if result == nullPtr then return $ Left "Definition not found"
|
|
else do
|
|
len <- c_strlen result
|
|
bs <- BSI.create (fromIntegral len) $ \p -> BSI.memcpy p (castPtr result) (fromIntegral len)
|
|
return $ Right bs
|
|
|
|
-- Get keys
|
|
type KeyEntry = (BS.ByteString, Word64)
|
|
getKeys :: MDict -> IO (Either String [KeyEntry])
|
|
getKeys (MDict fptr) = withForeignPtr fptr $ \ptr ->
|
|
alloca $ \lenPtr -> do
|
|
arrPtr <- c_mdict_keylist ptr lenPtr
|
|
len <- peek lenPtr
|
|
if arrPtr == nullPtr then return $ Left "Failed to retrieve key list"
|
|
else do
|
|
keyPtrs <- peekArray (fromIntegral len) arrPtr
|
|
items <- mapM handleItem keyPtrs
|
|
_ <- c_free_simple_key_list arrPtr len
|
|
return $ Right items
|
|
where
|
|
handleItem ptr = do
|
|
item <- peek ptr
|
|
bs <- packCString (keyWordPtr item)
|
|
return (bs, recordStart item)
|
|
packCString cstr = do
|
|
len <- c_strlen cstr
|
|
BSI.create (fromIntegral len) $ \p -> BSI.memcpy p (castPtr cstr) (fromIntegral len)
|
|
|
|
-- File type
|
|
getFileType :: MDict -> IO (Either String MDictType)
|
|
getFileType (MDict fptr) = withForeignPtr fptr $ \ptr -> do
|
|
ft <- c_mdict_filetype ptr
|
|
return $ case ft of
|
|
0 -> Right MDX
|
|
1 -> Right MDD
|
|
_ -> Left "Unknown file type"
|
|
|
|
-- List all keys (stdout)
|
|
listAllKeys :: MDict -> IO String
|
|
listAllKeys dict = do
|
|
ekeys <- getKeys dict
|
|
case ekeys of
|
|
Left err -> return $ "Error: " ++ err
|
|
Right keys -> return $ unlines [BSC.unpack bs | (bs, _) <- keys]
|
|
|
|
|
|
-- 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
|
|
|
|
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
|
|
|
|
-- Lookup each CSS in the dictionary or read from local file
|
|
|
|
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
|
|
|
|
-- | Helper: convert '/' to '\'
|
|
slashToBack :: Char -> Char
|
|
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)
|
|
|
|
-- | Lookup the actual media in a .mdd using your MDict bindings
|
|
lookupMedia :: FilePath -> String -> IO String
|
|
lookupMedia mddFile query = do
|
|
-- Open the MDD dictionary
|
|
withMDict mddFile $ \mdd -> do
|
|
result <- lookupWord mdd mddFile query
|
|
case result of
|
|
Left err -> do
|
|
putStrLn $ "ERROR: " ++ err
|
|
return "" -- leave empty if missing
|
|
Right base64 -> 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 =
|
|
withMDict dictFile $ \dict -> do
|
|
result <- lookupWord dict dictFile queryKey
|
|
case result of
|
|
Left err -> return (Left err)
|
|
Right html -> do
|
|
htmlWithMedia <- replaceMedia dictFile html
|
|
return (Right htmlWithMedia)
|
|
|
|
-- | fmap it over a collection of dictionaries
|
|
lookupInCollection :: FilePath -> String -> IO ()
|
|
lookupInCollection dir queryKey = do
|
|
files <- listFiles dir
|
|
forM_ files $ \file -> do
|
|
putStrLn $ "Processing: " ++ file
|
|
html <- lookupWordAtomic file queryKey -- needs to combine with replaceMedia
|
|
putStrLn html
|
|
putStrLn "-----"
|
|
|