From 832987a3881fdc79e193b6cc8e3a891569b7c2a5 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 3 Apr 2020 18:41:48 +1300 Subject: [PATCH] Draft C Bindings, so C APIs can be used for I/O. --- src/CExports.hs | 126 +++++++++++++++++++++++++++++++++++++++ src/Input.hs | 3 +- src/Links.hs | 2 +- src/Main.hs | 1 + src/Render.hs | 153 ++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 283 insertions(+), 2 deletions(-) create mode 100644 src/CExports.hs create mode 100644 src/Render.hs diff --git a/src/CExports.hs b/src/CExports.hs new file mode 100644 index 0000000..cfe6393 --- /dev/null +++ b/src/CExports.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +module CExports(c_newSession) where + +-- For c_newSession +import Network.URI.Fetch (Session, newSession) + +-- For data Page +import StyleTree (StyleTree) +import Data.CSS.Preprocessor.Conditions (ConditionalStyles, conditionalStyles) +import Text.XML +import qualified Data.Map.Strict as M +import Network.URI + +import Control.Monad (forM) + +-- For c_fetchURLs +import System.Directory (getCurrentDirectory) -- default referer URI +import Control.Concurrent.Async (forConcurrently, concurrently) +import Data.Maybe (catMaybes) + +import Input (fetchURLs) + +-- For c_renderDoc +import Render (retreiveStyles, renderDoc) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString (useAsCString) + +-- For c_extractLinks +import Links (Link(..), extractLinks) +import qualified Data.Text.Foreign as Txt + +-- Types I can export to C +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.C.String +import Foreign.Marshal.Array +import Foreign.Marshal.Alloc + +type CArray a = Ptr a + +foreign export ccall c_newSession :: IO (StablePtr Session) +foreign export ccall c_freeSession :: StablePtr Session -> IO () + +c_newSession = newSession >>= newStablePtr +c_freeSession = freeStablePtr + + +data Page = Page {url :: URI, css :: ConditionalStyles StyleTree, html :: Document} +type PtrPage = Ptr () + +foreign export ccall c_freePages :: CArray PtrPage -> IO () + +c_freePages c_pages = do + pages <- peekArray0 nullPtr c_pages + forM pages (freeStablePtr . castPtrToStablePtr) + free c_pages + + +foreign export ccall c_fetchURLs :: StablePtr Session -> PtrPage -> CArray CString -> IO (CArray PtrPage) + +c_fetchURLs c_session c_referer c_srcs = do + session <- deRefStablePtr c_session + referer <- if c_referer == nullPtr -- Can't check for NULL + then deRefStablePtr $ castPtrToStablePtr c_referer + else do + cwd <- getCurrentDirectory + return $ Page { + -- Default to URIs being relative to CWD. + url = URI {uriScheme = "file:", uriPath = cwd, + uriAuthority = Nothing, uriQuery = "", uriFragment = ""}, + -- Blank values: + css = conditionalStyles nullURI "temp", + html = Document { + documentPrologue = Prologue [] Nothing [], + documentRoot = Element "temp" M.empty [], + documentEpilogue = [] + } + } + emptyCStr <- newCString "" + srcCStrs <- peekArray0 emptyCStr c_srcs + srcs <- forConcurrently (pairs srcCStrs) $ \(c_mime, c_uri) -> do + mime <- peekCString c_mime + uri <- peekCString c_uri + return $ pair (words mime) <$> parseURIReference uri + ret <- fetchURLs session (html referer) (url referer) $ catMaybes srcs + c_ret <- forM ret $ \(url, html, css) -> + newStablePtr $ Page url css html + newArray0 nullPtr $ map castStablePtrToPtr c_ret + +pairs (a:b:c) = (a, b):pairs c +pairs _ = [] +pair a b = (a, b) + + +foreign export ccall c_renderDoc :: StablePtr Session -> PtrPage -> IO CString -- Hard to C bindings without IO + +c_renderDoc c_session c_page = do + session <- deRefStablePtr c_session + page <- deRefStablePtr $ castPtrToStablePtr c_page + css' <- retreiveStyles session $ css page + toStrict (renderDoc css' $ documentRoot $ html page) `useAsCString` \cstr -> do + str <- peekCString cstr + newCString str + + +foreign export ccall c_extractLinks :: PtrPage -> IO (CArray CString) + +c_extractLinks c_page = do + page <- deRefStablePtr $ castPtrToStablePtr c_page + ret <- forM (extractLinks $ html page) $ \link -> do + c_label <- text2cstring $ label link + c_title <- text2cstring $ title link + c_href <- newCString $ uriToString id (href link) "" + return [c_label, c_title, c_href] + emptyCStr <- newCString "" + newArray0 emptyCStr $ concat ret + +text2cstring txt = Txt.withCStringLen txt $ \s -> (peekCStringLen s >>= newCString) + +foreign export ccall c_docLinksAndRendering :: StablePtr Session -> PtrPage -> IO (CArray CString) + +c_docLinksAndRendering c_session c_page = do + (c_links, ssml) <- c_extractLinks c_page `concurrently` c_renderDoc c_session c_page + nil <- newCString "" + links <- peekArray0 nil c_links + newArray0 nil (ssml : links) diff --git a/src/Input.hs b/src/Input.hs index 0ed1a58..ecc89fa 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -87,11 +87,12 @@ fetchURLs session refererDoc refererURL srcs = forConcurrently srcs $ \(mime, ur let u = relativeTo url refererURL let charsets' = map Txt.unpack charsets resp <- fetchURL session mime u - case resp of + (a, b) <- case resp of ("text/css", bytes) -> let cssParser = CSS.parseForURL (conditionalStyles u "document") u in return (refererDoc, cssParser $ applyCSScharset charsets' bytes) _ -> parseDocument session resp >>= \doc -> return (doc, H2C.html2css doc refererURL) + return (u, a, b) applyCSScharset (charset:charsets) (Right bytes) | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text diff --git a/src/Links.hs b/src/Links.hs index 5ccb284..8ea0f6c 100644 --- a/src/Links.hs +++ b/src/Links.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Links(extractLinks, linkToText) where +module Links(extractLinks, linkToText, Link(..)) where import Text.XML import qualified Data.Map as M diff --git a/src/Main.hs b/src/Main.hs index 684dd2b..f95d0f7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -32,6 +32,7 @@ import StyleTree import SSML import Input import Links +import CExports main :: IO () main = do diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 index 0000000..76ea39e --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +module Render(retreiveStyles, renderDoc) where + +import qualified Data.ByteString.Lazy.Char8 as C8 +import qualified Data.ByteString.Lazy as B + +import qualified Text.XML as XML +import Data.Text as Txt (pack, unpack, Text(..), intercalate) + +import qualified Data.Map as M +import System.Directory as Dir +import Control.Monad +import System.IO (stdout, hPutStrLn) + +-- To handle text encoding errors, whilst trying them out +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (catch, evaluate) +import Data.Text.Encoding.Error (UnicodeException) + +--- External Rhapsode subcomponents +import qualified Data.CSS.Syntax.StyleSheet as CSS +import qualified Data.CSS.Style as Style +import qualified Data.CSS.Syntax.Tokens as CSSTok +import qualified Data.CSS.Preprocessor.Conditions as CSSCond +import qualified Data.HTML2CSS as H2C +import Network.URI.Fetch +import Network.URI.Charset + +-- Internal Rhapsode Subcomponents +import DefaultCSS +import StyleTree +import SSML +import Input +import Links + +renderDoc style html = + renderElLBS $ styleToSSML $ applyCounters $ stylize style html + +renderElLBS el = XML.renderLBS XML.def $ XML.Document { + XML.documentPrologue = XML.Prologue [] Nothing [], + XML.documentRoot = el, + XML.documentEpilogue = [] + } + +retreiveStyles :: Session -> CSSCond.ConditionalStyles StyleTree -> IO (Style.QueryableStyleSheet (Style.VarParser StyleTree)) +retreiveStyles manager authorStyle = do + let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` Txt.pack userAgentCSS + userStyle <- loadUserStyles agentStyle + importedStyle <- CSSCond.loadImports loadURL lowerVars lowerToks userStyle [] + return $ CSSCond.resolve lowerVars lowerToks Style.queryableStyleSheet importedStyle + where + loadURL url = do + response <- fetchURL manager ["text/css"] url + let charsets' = map unpack charsets + return $ case response of + ("text/css", Left text) -> text + ("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes + (_, _) -> "" + + lowerVars "speech" = CSSCond.B True + lowerVars "-rhapsode" = CSSCond.B True + lowerVars _ = CSSCond.B False + lowerToks _ = CSSCond.B False + +applyCSScharset (charset:charsets) bytes + | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text + | otherwise = applyCSScharset charsets bytes + where + text = convertCharset charset bytes +applyCSScharset _ bytes = convertCharset "utf-8" bytes +cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks, + (CSSTok.String charset:_) <- skipCSSspace toks' = charset + | otherwise = "" +skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks +skipCSSspace toks = toks + +loadUserStyles styles = do + dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode" + exists <- Dir.doesDirectoryExist dir + loadDirectory dir exists + where + loadDirectory _ False = return styles + loadDirectory dir True = do + files <- Dir.listDirectory dir + loadFiles (H2C.cssPriorityUser styles) files + loadFiles style (file:files) = do + source <- readFile file + CSS.parse style (Txt.pack source) `loadFiles` files + loadFiles style [] = return style + + +stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildText styles html + where + buildChild (Style.VarParser _ self) _ | content self == [] = Nothing + | otherwise = Just [Style.temp {content = content self}] + buildNode (Style.VarParser _ self) children = self {children = children} + buildText _ txt = Style.temp {content = [Content txt]} + +-------- +---- Counters +-------- +treeOrder :: (c -> c -> [Integer] -> StyleTree -> (c, StyleTree)) -> + c -> c -> [Integer] -> [StyleTree] -> (c, [StyleTree]) +treeOrder cb prevContext context (num:path) (node:nodes) = (tailContext, node' {children = children'} : nodes') + where + (selfContext, node') = cb prevContext context (num:path) node + (childContext, children') = treeOrder cb selfContext selfContext (0:num:path) $ children node + (tailContext, nodes') = treeOrder cb selfContext childContext (num + 1:path) nodes +treeOrder _ _ context _ [] = (context, []) +treeOrder _ _ _ [] _ = error "Invalid path during tree traversal!" + +inheritCounters path counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path + where cb val source = [counter | path `elem` [p | (p, _) <- source], counter@(path, _) <- val] +instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters + where + appendCounter new (old@((_:oldPath), _):olds) + | oldPath == tail path = new ++ olds + | otherwise = new ++ (old:olds) +instantiateCounters path instruct counters = foldl cb counters instruct + where cb counters' (name, value) = instantiateCounter counters' path name value +incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters + where addCounter ((_, new):_) ((path, old):rest) = (path, new + old):rest +incrementCounters path instruct counters = foldl cb counters instruct + where cb counters' (name, value) = incrementCounter counters' path name value +setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters + where setCounter' ((_, val):_) ((path, _):rest) = (path, val):rest +setCounters path instruct counters = foldl cb counters instruct + where cb counters' (name, value) = setCounter counters' path name value + +renderCounter counters (Content txt) = Content txt +renderCounter counters (Counter name) + | Just ((_, count):_) <- name `M.lookup` counters = Content $ Txt.pack $ show count + | otherwise = Content "" +renderCounter counters (Counters name sep) + | Just counter <- name `M.lookup` counters = Content $ Txt.intercalate sep [ + Txt.pack $ show count | (_, count) <- reverse counter + ] + | otherwise = Content "" +renderCounters node counters = (counters, node { + content = map (renderCounter counters) $ content node, + counterSet = [(name, value) | (name, ((_, value):_)) <- M.toList counters] + }) + +applyCounters root = root { + children = snd $ treeOrder cb M.empty M.empty [0] $ children root + } where + cb :: M.Map Text [([Integer], Integer)] -> M.Map Text [([Integer], Integer)] -> + [Integer] -> StyleTree -> (M.Map Text [([Integer], Integer)], StyleTree) + cb counterSource valueSource path node = renderCounters node $ + setCounters path (counterSet node) $ + incrementCounters path (counterIncrement node) $ + instantiateCounters path (counterReset node) $ + inheritCounters path counterSource valueSource -- 2.30.2