{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Render(retreiveStyles, renderDoc, c_renderDoc) where
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 Data.FileEmbed
--- 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
import Network.URI.Fetch
import Network.URI.Charset
--- For CSS assets
import Data.List (nub, elem)
import Control.Concurrent.Async (forConcurrently)
import System.IO.Temp
-- Internal Rhapsode Subcomponents
import StyleTree
import SSML
import Input (writeDownloadToFile)
-- C API
import Types
import Foreign.StablePtr
import Foreign.C.String
import Data.ByteString (useAsCString)
renderDoc :: Style.QueryableStyleSheet (Style.VarParser StyleTree) -> XML.Element -> B.ByteString
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 (CSSCond.ConditionalStyles StyleTree)
retreiveStyles manager authorStyle = do
let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile "useragent.css")
userStyle <- loadUserStyles agentStyle
CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
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
(_, _) -> ""
resolve' :: CSS.StyleSheet s => s -> CSSCond.ConditionalStyles StyleTree -> s
resolve' = CSSCond.resolve lowerVars lowerToks
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]}
--------
---- Download assets
--------
-- TODO upstream into Haskell Stylist, or a new HURL Stylist hackage.
data StyleAssets = StyleAssets {
filterProps :: [Txt.Text],
assets :: [URI]
}
instance CSS.StyleSheet StyleAssets where
addRule (StyleAssets filterProps self) (CSS.StyleRule _ props _) =
StyleAssets filterProps $ nub (
self ++ [uri | (prop, val) <- props,
prop `elem` filterProps,
CSSTok.Url text <- val,
Just uri <- [parseAbsoluteURI $ Txt.unpack text]]
)
downloadAssets session mimes (StyleAssets _ assets) =
forConcurrently assets (\uri ->
fetchURL' session mimes uri >>= saveAsset mimes) >>=
return . zip assets
-- variant of HURL fetchURL which includes about:link.oga & about:bullet-point.wav
fetchURL' _ _ (URI "about:" Nothing "link.oga" _ _) =
return ("application/ogg", Right $ B.fromStrict $(embedFile "link.oga"))
fetchURL' _ _ (URI "about:" Nothing "bulletpoint.wav" _ _) =
return ("audio/vnd.wav", Right $ B.fromStrict $(embedFile "bulletpoint.wav"))
fetchURL' s m u = fetchURL s m u
saveAsset mimes (mime, download)
| mime `notElem` mimes = return nullURI
| otherwise = withSystemTempFile "rhapsode-asset" $ writeDownloadToFile download
rewritePropertyVal rewrites (CSSTok.Url text:vals)
| Just uri <- parseURIReference $ Txt.unpack text, Just rewrite <- uri `M.lookup` rewrites =
CSSTok.Url (Txt.pack $ uriToString id rewrite "") : rewritePropertyVal rewrites vals
| otherwise = CSSTok.Url "" : rewritePropertyVal rewrites vals
rewritePropertyVal rewrites (val:vals) = val:rewritePropertyVal rewrites vals
rewritePropertyVal _ [] = []
data URIRewriter s = URIRewriter (M.Map URI URI) s
instance CSS.StyleSheet s => CSS.StyleSheet (URIRewriter s) where
setPriority p (URIRewriter r s) = URIRewriter r $ CSS.setPriority p s
addRule (URIRewriter r s) (CSS.StyleRule sel props psuedo) =
URIRewriter r $ CSS.addRule s $ CSS.StyleRule sel [
(prop, rewritePropertyVal r val) | (prop, val) <- props
] psuedo
addAtRule (URIRewriter r s) name toks =
let (self', toks') = CSS.addAtRule s name toks in (URIRewriter r s, toks)
--------
---- 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
--------
---- C API
--------
foreign export ccall c_renderDoc :: StablePtr Session -> StablePtr Page -> IO CString -- Hard to C bindings without IO
c_renderDoc c_session c_page = do
session <- deRefStablePtr c_session
page <- deRefStablePtr c_page
css' <- retreiveStyles session $ css page
assets <- downloadAssets session [
-- FIXME couldn't find MIMEtypes for all the audio formats
"audio/vnd.wav", "audio/x-aiff", "audio/basic", "audio/8svx", "audio/x-8svx",
"audio/x-voc", "application/x-pagerecall", "audio/x-caf", "audio/flac",
"audio/x-oga", "application/x-ogg", "application/ogg"
] $ resolve' (StyleAssets ["cue-before", "cue-after", "cue"] []) css'
let qCSS = resolve' Style.queryableStyleSheet css'
let ssml = renderDoc qCSS $ XML.documentRoot $ html page
B.toStrict ssml `useAsCString` \cstr -> do
str <- peekCString cstr
newCString str