From 0a65b2c1f05818843df4d82320bced104b8baa57 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 8 Apr 2020 13:15:41 +1200 Subject: [PATCH] Download CSS assets, including new useragent audio cues. Audio cues are public domain from freesound.org and archive.org via elementary OS's sound theme. --- LICENSE | 5 +++ rhapsode.cabal | 5 ++- soundfx-SOURCES.md | 4 -- src/DefaultCSS.hs | 81 --------------------------------------- src/Input.hs | 6 ++- src/Render.hs | 95 ++++++++++++++++++++++++++++++++++++++++------ 6 files changed, 95 insertions(+), 101 deletions(-) delete mode 100644 soundfx-SOURCES.md delete mode 100644 src/DefaultCSS.hs diff --git a/LICENSE b/LICENSE index 2b3e9b0..db3fd86 100644 --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/rhapsode.cabal b/rhapsode.cabal index 5a32941..905a005 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -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 diff --git a/soundfx-SOURCES.md b/soundfx-SOURCES.md deleted file mode 100644 index 3d6c3ff..0000000 --- a/soundfx-SOURCES.md +++ /dev/null @@ -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 diff --git a/src/DefaultCSS.hs b/src/DefaultCSS.hs deleted file mode 100644 index 677c98e..0000000 --- a/src/DefaultCSS.hs +++ /dev/null @@ -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}" - ] diff --git a/src/Input.hs b/src/Input.hs index ffe9f11..71996a6 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -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 () diff --git a/src/Render.hs b/src/Render.hs index d5673c5..3ec3813 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -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 @@ -91,6 +101,58 @@ stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildT 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 -------- @@ -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 -- 2.30.2