From df26d5938cc8c127af15e72d21f20f52e91f69c7 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 29 Oct 2022 14:17:26 +1300 Subject: [PATCH] Various tidies, including disabling wakeword in absence of Voice2JSON. --- rhapsode.cabal | 4 +-- src/CExports.hs | 90 ++++++++++++++++++++++++++++++++++++++++++++++++- src/Input.hs | 84 --------------------------------------------- src/Render.hs | 39 ++++++++++++++++----- src/Types.hs | 42 +---------------------- src/main.c | 1 + useragent.css | 2 +- 7 files changed, 124 insertions(+), 138 deletions(-) delete mode 100644 src/Input.hs diff --git a/rhapsode.cabal b/rhapsode.cabal index a300fc6..7bfe367 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -51,10 +51,10 @@ cabal-version: >=1.10 library -- .hs or .lhs file containing the Main module. - exposed-modules: CExports, Input, Links, Render, Types + exposed-modules: CExports, Links, Render -- Modules included in this library. - other-modules: SSML, SpeechStyle + other-modules: Types, SSML, SpeechStyle -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/CExports.hs b/src/CExports.hs index df516a4..f8eef9b 100644 --- a/src/CExports.hs +++ b/src/CExports.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} module CExports where import Types @@ -6,15 +6,29 @@ import Network.URI.Fetch (Session) import Render (c_renderDoc) import Links (c_extractLinks) + import qualified Text.XML as XML +import Text.XML (Document(..), Prologue(..), Element(..)) import qualified Data.Text as Txt import qualified Data.Text.Lazy as Txt (fromStrict) import qualified Data.Map as M +import qualified Data.ByteString.Lazy as B + +import Network.URI +import Network.URI.Fetch +import Network.URI.Fetch.XML (fetchDocument, loadVisited) + +import System.IO +import System.Directory +import System.FilePath (()) +import Data.FileEmbed +import Data.CSS.Preprocessor.Conditions (conditionalStyles) -- Types I can export to C import Foreign.StablePtr import Foreign.C.String import Foreign.Marshal.Array +import Data.Maybe (fromMaybe) -- FIXME: Segfaults, was intended for a playlist feature --foreign export ccall c_fetchURLs :: StablePtr Session -> PtrPage -> CArray CString -> IO (CArray PtrPage) @@ -61,3 +75,77 @@ c_ssmlHasMark c_ident c_ssml = do case XML.parseText XML.def $ Txt.fromStrict $ Txt.pack ssml of Left _ -> return False Right doc -> return $ ssmlHasMark (Txt.pack ident) $ XML.documentRoot doc + +foreign export ccall c_initialReferer :: IO (StablePtr (Page RhapsodeCSS)) + +c_initialReferer = do + cwd <- getCurrentDirectory + hist <- loadVisited "rhapsode" + newStablePtr $ Page { + -- Default to URIs being relative to CWD. + pageURL = URI {uriScheme = "file:", uriPath = cwd, + uriAuthority = Nothing, uriQuery = "", uriFragment = ""}, + -- Blank values: + css = conditionalStyles nullURI "temp", + domain = "temp", + html = Document { + documentPrologue = Prologue [] Nothing [], + documentRoot = Element "temp" M.empty [], + documentEpilogue = [] + }, + pageTitle = "", pageMIME = "", apps = [], + backStack = [], forwardStack = [], visitedURLs = hist, + initCSS = conditionalStyles, + appName = "rhapsode" + } + +foreign export ccall c_freePage :: StablePtr (Page RhapsodeCSS) -> IO () + +c_freePage = freeStablePtr + +-------- +---- Network requests +-------- +foreign export ccall c_newSession :: IO (StablePtr Session) +foreign export ccall c_freeSession :: StablePtr Session -> IO () + +c_newSession = do + sess <- newSession + newStablePtr $ sess {aboutPages = map lazify $(embedDir $ buildDirFile "about")} + where lazify (a, b) = (a, B.fromStrict b) +c_freeSession = freeStablePtr + + +foreign export ccall c_fetchURL :: StablePtr Session -> CString -> StablePtr (Page RhapsodeCSS) -> CString -> IO (StablePtr (Page RhapsodeCSS)) + +c_fetchURL c_session c_mimes c_referer c_uri = do + session <- deRefStablePtr c_session + mimes <- peekCString c_mimes + referer <- deRefStablePtr c_referer + uri <- peekCString c_uri + let uri' = nullURI `fromMaybe` parseURIReference uri `relativeTo` pageURL referer + doc <- fetchDocument session referer uri' + newStablePtr doc + +foreign export ccall c_enableLogging :: StablePtr Session -> IO (StablePtr Session) + +c_enableLogging c_session = do + ret <- deRefStablePtr c_session >>= enableLogging + freeStablePtr c_session + newStablePtr ret + +foreign export ccall c_writeLog :: CString -> StablePtr Session -> IO () + +c_writeLog c_path c_session = do + path <- peekCString c_path + withFile path AppendMode (\logfile -> deRefStablePtr c_session >>= writeLog logfile) + +foreign export ccall c_lastVisited :: CString -> IO CString +c_lastVisited def = do + path <- ( "history.gmni") <$> getXdgDirectory XdgData "rhapsode" + exists <- doesFileExist path + if not exists then return def else do + file <- readFile path + case map words $ lines file of + (_:url:_):_ -> newCString url + _ -> return def diff --git a/src/Input.hs b/src/Input.hs deleted file mode 100644 index 4635854..0000000 --- a/src/Input.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Input(fetchDocument, readStrict) where - -import Data.Text.Lazy (fromStrict) -import qualified Data.Text as Txt -import qualified Data.Text.IO as Txt -import Data.Text.Encoding -import qualified Data.Text.Lazy as LTxt -import qualified Data.ByteString.Lazy as B -import qualified Text.XML as XML -import Network.URI -import Network.URI.Fetch -import Network.URI.Fetch.XML (fetchDocument) -import Network.URI.Charset -import qualified Data.Map as M -import qualified Data.Set as Set -import Data.List (intercalate) -import Data.Time.Clock - --- For alternative styles -import qualified Data.CSS.Syntax.Tokens as CSSTok -import Data.CSS.Syntax.StyleSheet -import Data.CSS.Preprocessor.Conditions (conditionalStyles) - -import System.IO -import System.IO.Temp -import System.Directory -import System.FilePath (()) -import Data.FileEmbed - --- For C API -import Types -import Data.Maybe (fromMaybe) -import Foreign.StablePtr -import Foreign.C.String - --------- ----- C API --------- -foreign export ccall c_newSession :: IO (StablePtr Session) -foreign export ccall c_freeSession :: StablePtr Session -> IO () - -c_newSession = do - sess <- newSession - newStablePtr $ sess {aboutPages = map lazify $(embedDir $ buildDirFile "about")} - where lazify (a, b) = (a, B.fromStrict b) -c_freeSession = freeStablePtr - - -foreign export ccall c_fetchURL :: StablePtr Session -> CString -> StablePtr (Page RhapsodeCSS) -> CString -> IO (StablePtr (Page RhapsodeCSS)) - -c_fetchURL c_session c_mimes c_referer c_uri = do - session <- deRefStablePtr c_session - mimes <- peekCString c_mimes - referer <- deRefStablePtr c_referer - uri <- peekCString c_uri - let uri' = nullURI `fromMaybe` parseURIReference uri `relativeTo` pageURL referer - doc <- fetchDocument session referer uri' - newStablePtr doc - -foreign export ccall c_enableLogging :: StablePtr Session -> IO (StablePtr Session) - -c_enableLogging c_session = do - ret <- deRefStablePtr c_session >>= enableLogging - freeStablePtr c_session - newStablePtr ret - -foreign export ccall c_writeLog :: CString -> StablePtr Session -> IO () - -c_writeLog c_path c_session = do - path <- peekCString c_path - withFile path AppendMode (\logfile -> deRefStablePtr c_session >>= writeLog logfile) - -foreign export ccall c_lastVisited :: CString -> IO CString -c_lastVisited def = do - path <- ( "history.gmni") <$> getXdgDirectory XdgData "rhapsode" - exists <- doesFileExist path - if not exists then return def else do - file <- readFile path - case map words $ lines file of - (_:url:_):_ -> newCString url - _ -> return def diff --git a/src/Render.hs b/src/Render.hs index e1ad2fb..a8ba53a 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -22,7 +22,7 @@ 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) +import Stylist (cssPriorityAgent, cssPriorityUser, attrTest, elementPath) import Data.HTML2CSS (el2stylist) import Network.URI @@ -106,16 +106,16 @@ loadUserStyles styles = do 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 <- path anchor] + CSSTok.Colon : CSSTok.Ident "root" : concat [ selLayer n | n <- parsePath anchor] where - path ('.':anchor) = [] : path anchor - path (c:anchor) | n:path' <- path anchor, c >= '0' && c <= '9' = (c:n):path' - path [] = [[]] - path _ = [] - selLayer n = [ CSSTok.Delim '>', CSSTok.Colon, CSSTok.Function "nth-child", @@ -124,20 +124,40 @@ targetSel ('#':'.':anchor) = 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 = +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 -------- @@ -169,7 +189,8 @@ c_renderDoc c_session c_page rewriteURLs = do session <- deRefStablePtr c_session page <- deRefStablePtr c_page css' <- retreiveStyles session $ css page - let pseudoFilter = rhapsodePseudoFilter (pageURL page) $ visitedURLs 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" diff --git a/src/Types.hs b/src/Types.hs index 88ca083..e8b197b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,57 +1,17 @@ -{-# LANGUAGE OverloadedStrings #-} module Types(CArray, Page(..), Application(..), RhapsodeCSS, buildDirFile, readStrict) where -import System.Directory (getCurrentDirectory) -- default referer URI import SpeechStyle (SpeechStyle) import Data.CSS.Preprocessor.Conditions (ConditionalStyles, conditionalStyles) import Data.CSS.Preprocessor.Text (TextStyle) -import Text.XML -import qualified Data.Map.Strict as M -import Network.URI + import Network.URI.Fetch (Application(..), url) import Network.URI.Fetch.XML (Page(..), loadVisited, readStrict) --- For the in-memory history log -import qualified Data.Set as Set -import Data.Set (Set) -import Data.Text (Text(..)) -import qualified Data.Text as Txt -import System.Directory import System.FilePath (()) -import Control.Parallel (par) - import Foreign.Ptr -import Foreign.StablePtr buildDir = "." buildDirFile = (buildDir ) type CArray a = Ptr a type RhapsodeCSS = ConditionalStyles (TextStyle SpeechStyle) - -foreign export ccall c_initialReferer :: IO (StablePtr (Page RhapsodeCSS)) - -c_initialReferer = do - cwd <- getCurrentDirectory - hist <- loadVisited "rhapsode" - newStablePtr $ Page { - -- Default to URIs being relative to CWD. - pageURL = URI {uriScheme = "file:", uriPath = cwd, - uriAuthority = Nothing, uriQuery = "", uriFragment = ""}, - -- Blank values: - css = conditionalStyles nullURI "temp", - domain = "temp", - html = Document { - documentPrologue = Prologue [] Nothing [], - documentRoot = Element "temp" M.empty [], - documentEpilogue = [] - }, - pageTitle = "", pageMIME = "", apps = [], - backStack = [], forwardStack = [], visitedURLs = hist, - initCSS = conditionalStyles, - appName = "rhapsode" - } - -foreign export ccall c_freePage :: StablePtr (Page RhapsodeCSS) -> IO () - -c_freePage = freeStablePtr diff --git a/src/main.c b/src/main.c index e1ae22a..10df060 100644 --- a/src/main.c +++ b/src/main.c @@ -529,6 +529,7 @@ int main(int argc, char **argv) { v2j_profile = ""; } else if (dir_exists(v2j_profile)) v2j_profile = ""; + use_wakeword &= *v2j_profile != '\0'; char *ssml, **links, *uri; int read_links = 0; diff --git a/useragent.css b/useragent.css index 1f73679..9cad23c 100644 --- a/useragent.css +++ b/useragent.css @@ -118,7 +118,7 @@ aside {voice-volume: soft} mark {voice-range: high; voice-pitch: high; cue-before: url(about:found.wav)} details > :not(summary:first-of-type) {speak: never} -details:target > *, details[open] > * {speak: always} +details:target > *, details:target-within > *, details[open] > * {speak: always} /* Localized into: - English -- 2.30.2