A src/CExports.hs => src/CExports.hs +126 -0
@@ 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)
M src/Input.hs => src/Input.hs +2 -1
@@ 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
M src/Links.hs => src/Links.hs +1 -1
@@ 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
M src/Main.hs => src/Main.hs +1 -0
@@ 32,6 32,7 @@ import StyleTree
import SSML
import Input
import Links
+import CExports
main :: IO ()
main = do
A src/Render.hs => src/Render.hs +153 -0
@@ 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