1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
{-# 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
import Data.Maybe (fromMaybe, maybeToList)
import Text.Read (readMaybe)
--- External Rhapsode subcomponents
import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Style as Style
import Data.CSS.StyleTree
import qualified Data.CSS.Syntax.Tokens as CSSTok
import qualified Data.CSS.Preprocessor.Conditions as CSSCond
import Data.CSS.Preprocessor.Assets
import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo
import qualified Data.CSS.Preprocessor.Text as CSSTxt
import Stylist (cssPriorityAgent, cssPriorityUser, attrTest, elementPath)
import Data.HTML2CSS (el2stylist)
import Network.URI
import Network.URI.Fetch
import Network.URI.Charset
import Network.URI.Fetch.XML (applyCSScharset)
--- For CSS assets
import Data.List (nub, elem)
import Control.Concurrent.Async (forConcurrently)
import System.IO.Temp
import Control.Exception (catch)
--- For psuedoclasses
import qualified Data.Set as Set
import qualified Data.CSS.Syntax.Selector as CSSSel
-- Internal Rhapsode Subcomponents
import SpeechStyle
import SSML
-- C API
import Types
import Foreign.StablePtr
import Foreign.C.String
import Data.ByteString (useAsCString)
renderDoc :: Style.QueryableStyleSheet (Style.VarParser (CSSTxt.TextStyle SpeechStyle)) -> XML.Element -> B.ByteString
renderDoc style html =
renderElLBS $ styleToSSML $ CSSTxt.resolve $ inlinePseudos' $ stylize style $ el2stylist html
inlinePseudos' :: Style.PropertyParser s => StyleTree [(Text, Style.VarParser s)] -> StyleTree s
inlinePseudos' (StyleTree self childs) = StyleTree {
style = fromMaybe Style.temp $ Style.innerParser <$> lookup "" self,
children = pseudo "before" ++ map inlinePseudos' childs ++ pseudo "after"
} where
pseudo n
| Just style <- Style.innerParser <$> lookup n self,
Just style' <- Style.longhand style style "::" [CSSTok.Ident n] = [StyleTree style' []]
| Just style <- Style.innerParser <$> lookup n self = [StyleTree style []]
| otherwise = []
renderElLBS el = XML.renderLBS XML.def $ XML.Document {
XML.documentPrologue = XML.Prologue [] Nothing [],
XML.documentRoot = el,
XML.documentEpilogue = []
}
retreiveStyles :: Session -> CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle) -> IO (CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle))
retreiveStyles manager authorStyle = do
let agentStyle = cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile $ buildDirFile "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 (CSSTxt.TextStyle SpeechStyle) -> s
resolve' = CSSCond.resolve lowerVars lowerToks
lowerVars "speech" = CSSCond.B True
lowerVars "-rhapsode" = CSSCond.B True
lowerVars _ = CSSCond.B False
lowerToks _ = CSSCond.B False
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 (cssPriorityUser styles) files
loadFiles style (file:files) = do
source <- readFile file
CSS.parse style (Txt.pack source) `loadFiles` files
loadFiles style [] = return style
parsePath ('.':anchor) = [] : parsePath anchor
parsePath (c:anchor) | n:path' <- parsePath anchor, c >= '0' && c <= '9' = (c:n):path'
parsePath [] = [[]]
parsePath _ = []
targetSel "" = [CSSTok.Ident "main"]
targetSel "#" = [CSSTok.Colon, CSSTok.Ident "root"]
targetSel ('#':'.':anchor) =
CSSTok.Colon : CSSTok.Ident "root" : concat [ selLayer n | n <- parsePath anchor]
where
selLayer n = [
CSSTok.Delim '>',
CSSTok.Colon, CSSTok.Function "nth-child",
CSSTok.Number (pack n) (CSSTok.NVInteger $ fromMaybe 0 $ readMaybe n),
CSSTok.RightParen]
targetSel ('#':id) = [CSSTok.Hash CSSTok.HUnrestricted $ Txt.pack id]
targetSel _ = []
targetWithinSel _ "#" = []
targetWithinSel _ ('#':'.':anchor) = map (fromMaybe 0 . readMaybe) $ parsePath anchor
targetWithinSel tree ('#':id)
| (el:_) <- treeFind tree $ attrTest Nothing "id" $ CSSSel.Include $ Txt.pack id =
elementPath el
targetWithinSel _ _ = []
testVisited :: Set.Set Text -> URI -> String -> Bool
testVisited hist base val = uriToText url `Set.member` hist
where
url = fromMaybe nullURI (parseURIReference val) `relativeTo` base
uriToText uri = pack $ uriToString id uri ""
rhapsodePseudoFilter url hist tree =
-- Note: not all links must have an href tag, but it's not a bad approximation visited links must.
-- Doing it this way is easier to implement in Haskell Stylist.
CSSPseudo.addTest "visited" Nothing "href" (CSSSel.PropertyFunc $ testVisited hist url) $
CSSPseudo.addRewrite "link" "[src], [href], details > summary, tr:first-of-type th" $
CSSPseudo.addRewrite' "target" (targetSel $ uriFragment url) $
CSSPseudo.addContains "target-within" (targetWithinSel tree $ uriFragment url) $
CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet
-- Apparantly I forgot to export this API...
treeFind :: StyleTree p -> (p -> Bool) -> [p]
treeFind p test = filter test $ treeFlattenAll p
-- And forgot to export this too...
treeFlattenAll :: StyleTree p -> [p]
treeFlattenAll = treeFlattenAll' . children
treeFlattenAll' :: [StyleTree p] -> [p]
treeFlattenAll' (StyleTree p []:ps) = p : treeFlattenAll' ps
treeFlattenAll' (StyleTree p childs:sibs) = p : treeFlattenAll' childs ++ treeFlattenAll' sibs
treeFlattenAll' [] = []
--------
---- Download assets
--------
downloadAssets session mimes (StyleAssets _ assets) = do
dir <- Dir.getXdgDirectory Dir.XdgCache "rhapsode"
Dir.removeDirectoryRecursive dir `catch` ignoreError -- Clear cache.
Dir.createDirectoryIfMissing True dir
-- Ensure core audio cues are saved with predictable names for UI layer to use.
let assets' = nub $ (u "about:link.wav":u "about:bulletpoint.wav":assets)
fetchURLs session mimes assets' $ filterMIMEs mimes $ saveDownload nullURI dir
where
ignoreError :: IOError -> IO ()
ignoreError _ = return ()
u = fromMaybe (URI "about:" Nothing "invalid" "" "") . parseAbsoluteURI
filterMIMEs mimes cb download@(_, mime, _)
| mime `elem` mimes = cb download
| otherwise = return nullURI
--------
---- C API
--------
foreign export ccall c_renderDoc :: StablePtr Session -> StablePtr (Page RhapsodeCSS) -> Bool -> IO CString -- Hard to C bindings without IO
c_renderDoc c_session c_page rewriteURLs = do
session <- deRefStablePtr c_session
page <- deRefStablePtr c_page
css' <- retreiveStyles session $ css page
let html' = XML.documentRoot $ html page
let pseudoFilter = rhapsodePseudoFilter (pageURL page) (visitedURLs page) (el2stylist html')
qCSS <- if rewriteURLs then do
assets <- downloadAssets session [
"audio/vnd.wav"
] $ resolve' (StyleAssets ["cue-before", "cue-after", "cue"] []) css'
let URIRewriter _ qCSS' = resolve' (URIRewriter assets pseudoFilter) css'
return $ CSSPseudo.inner qCSS'
else return $ CSSPseudo.inner $ resolve' pseudoFilter css'
let ssml = renderDoc qCSS $ XML.documentRoot $ html page
B.toStrict ssml `useAsCString` \cstr -> do
str <- peekCString cstr
newCString str