6 files changed, 95 insertions(+), 101 deletions(-)

M LICENSE
M rhapsode.cabal
D soundfx-SOURCES.md
D src/DefaultCSS.hs
M src/Input.hs
M src/Render.hs

@@ 1,3 1,8 @@
+Sound files are in the public domain. The rest of the code, and it's documentation,
+is under the GNU GPL v3+.
+
+---
+
                     GNU GENERAL PUBLIC LICENSE
                        Version 3, 29 June 2007
 

@@ 54,7 54,7 @@ library
   exposed-modules: CExports, Input, Links, Render, Types
   
   -- Modules included in this library.
-  other-modules:       DefaultCSS, SSML, StyleTree
+  other-modules:       SSML, StyleTree
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    


@@ 64,7 64,8 @@ library
         html-conduit, xml-conduit, text, containers, data-default-class,
         network-uri,
         stylist >= 1.1, css-syntax, xml-conduit-stylist, scientific,
-        async, hurl >= 1.2.0.0, filepath, temporary
+        async, hurl >= 1.2.0.0, filepath, temporary,
+        file-embed >= 0.0.9 && < 0.1
   
   -- Directories containing source files.
   hs-source-dirs:      src

@@ 1,4 0,0 @@
-The sound effects packaged with Rhapsode have been provided by:
-
-* [PCDav](https://www.pacdv.com/sounds/interface_sounds-3.html) [Interface 81](https://www.pacdv.com/sounds/interface_sound_effects/sound81.wav) for bulletpoint.wav
-* [SoundBible](http://soundbible.com/tags-beep.html) [Electronic Chime](http://soundbible.com/1598-Electronic-Chime.html) for link.wav>
\ No newline at end of file

@@ 1,81 0,0 @@
-module DefaultCSS(userAgentCSS) where
-
-userAgentCSS = unlines [
-  "head, link, meta, style, script, title, base {speak: never}",
-  "datalist, template {speak: never}",
-  "html {speak-as: normal no-punctuation}",
-  "",
-  "/** Forms **/",
-  "button, select, textarea, input, output {speak: never} /* Leave to special form entry mode */",
-  "button[type=submit] {speak: always}",
-  "input[type=submit][value] {speak: always; content: attr(value)}",
-  "",
-  "/** Tables **/",
-  "table::before {content: 'Table'; voice-volume: x-soft}",
-  "tr {cue-before: url(bulletpoint.wav);}",
-  "td, th {cue-before: url(bulletpoint.wav) -1db;}",
-  "th > :th /* Rhapsode-specific, selects inlined table headers */ {speak: never;}",
-  "table caption {voice-volume: soft}",
-  "",
-  "/** Sectioning **/",
-  "footer, header {voice-volume: soft}",
-  "nav {speak: never} /* Expose the links for navigation, but not narration */",
-  "h1, h2, h3, h4, h5, h6, legend, th, summary, dt {voice-stress: strong}",
-  "h1 {pause: x-strong; voice-rate: x-slow}",
-  "h2 {pause: strong; voice-rate: slow}",
-  "h3, th, summary, legend, dt {pause: medium; voice-rate: medium}",
-  "h4 {pause: weak; voice-rate: fast}",
-  "h5, h6 {pause: x-weak; voice-rate: fast}",
-  "h6 {voice-pitch: high}",
-  "",
-  "/** Text **/",
-  "hr {pause: x-strong}",
-  "p, pre, samp, blockquote {pause: strong}",
-  "pre, address, samp {speak-as: literal-punctuation}",
-  "pre, samp, code {voice: neutral 2}",
-  "a[href], :link {cue-before: url(link.wav); voice-pitch: low}",
-  ":link:visited {cue-before: url(link.wav) -1db}",
-  "img {voice-volume: soft; content: 'Image: ' attr(src)}",
-  "img[alt] {content: 'Image: ' attr(alt)}",
-  "",
-  "b, strong {voice-rate: slow}",
-  "i, em {voice-stress: strong}",
-  "br {pause: medium}",
-  "code {speak-as: literal-punctuation}",
-  "s, del {voice-volume: x-soft}",
-  "u, ins {voice-volume: loud}",
-  "",
-  "/** lists **/",
-  "li, dt, dd {cue-before: url(bulletpoint.wav); pause: strong}",
-  "li::before, dt::before, dd::before {content: 'd'} /* Since the cue-before isn't coming accross */",
-  "li li, dd dt, dd dd {cue-before: url(bulletpoint.wav) -1db}",
-  "li li li, dd dd dt, dd dd dd {cue-before: url(bulletpoint.wav) -2db}",
-  "li li li li, dd dd dd dt, dd dd dd dd {cue-before: url(bulletpoint.wav) -3db}",
-  "li li li li li, dd dd dd dd dt, dd dd dd dd dd {",
-  "       cue-before: url(bulletpoint.wav) -4db",
-  "}",
-  "li li li li li li, dd dd dd dd dd dt, dd dd dd dd dd dd {",
-  "       cue-before: url(bulletpoint.wav) -5db",
-  "}",
-  "",
-  "ol {counter-reset: -rhaps-ol}",
-  "ol li::before {",
-  "counter-increment: -rhaps-ol;",
-  "content: counters(-rhaps-ol, ' ')",
-  "}",
-  "",
-  "",
-  "/** HTML6 **/",
-  "abbr[title]::after {content: attr(title); voice-volume: x-soft}",
-  "abbr {speak-as: spell-out}",
-  "",
-  "q, blockquote {voice-family: female 2}",
-  "cite {voice-stress: reduce}",
-  "dialog {speak: never} dialog[open] {speak: always}",
-  "kbd {speak-as: spell-out}",
-  "progress {content: attr(value) ' of ' attr(max)}",
-  "sub {voice-rate: x-fast}",
-  "sup {voice-rate: fast}",
-  "var {voice-rate: slow}",
-  "aside {voice-volume: soft}"
-  ]

@@ 1,5 1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Input(fetchDocument, docForText) where
+module Input(fetchDocument, docForText, writeDownloadToFile) where
 
 import           Data.Text.Lazy (fromStrict)
 import qualified Data.Text as Txt


@@ 80,7 80,9 @@ docForText txt = XML.Document {
         XML.documentEpilogue = []
     }
 
--- C API
+--------
+---- C API
+--------
 foreign export ccall c_newSession :: IO (StablePtr Session)
 foreign export ccall c_freeSession :: StablePtr Session -> IO ()
 

@@ 1,4 1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Render(retreiveStyles, renderDoc, c_renderDoc) where
 
 import qualified Data.ByteString.Lazy as B


@@ 7,6 8,7 @@ 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


@@ 14,13 16,19 @@ 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 DefaultCSS
 import StyleTree
 import SSML
+import Input (writeDownloadToFile)
 
 -- C API
 import Types


@@ 28,6 36,7 @@ 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
 


@@ 37,12 46,11 @@ renderElLBS el = XML.renderLBS XML.def $ XML.Document {
         XML.documentEpilogue = []
     }
 
-retreiveStyles :: Session -> CSSCond.ConditionalStyles StyleTree -> IO (Style.QueryableStyleSheet (Style.VarParser StyleTree))
+retreiveStyles :: Session -> CSSCond.ConditionalStyles StyleTree -> IO (CSSCond.ConditionalStyles StyleTree)
 retreiveStyles manager authorStyle = do
-    let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` Txt.pack userAgentCSS
+    let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile "useragent.css")
     userStyle <- loadUserStyles agentStyle
-    importedStyle <- CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
-    return $ CSSCond.resolve lowerVars lowerToks Style.queryableStyleSheet importedStyle
+    CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
   where
     loadURL url = do
         response <- fetchURL manager ["text/css"] url


@@ 52,10 60,12 @@ retreiveStyles manager authorStyle = do
             ("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
+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


@@ 92,6 102,58 @@ stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildT
         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)) ->


@@ 146,14 208,23 @@ applyCounters root = root {
             incrementCounters path (counterIncrement node) $
             instantiateCounters path (counterReset node) $
             inheritCounters path counterSource valueSource
-
--- C API
+--------
+---- 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
-    B.toStrict (renderDoc css' $ XML.documentRoot $ html page) `useAsCString` \cstr -> do
+    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