~alcinnz/rhapsode

df26d5938cc8c127af15e72d21f20f52e91f69c7 — Adrian Cochrane 1 year, 7 months ago 091c7d8
Various tidies, including disabling wakeword in absence of Voice2JSON.
7 files changed, 124 insertions(+), 138 deletions(-)

M rhapsode.cabal
M src/CExports.hs
D src/Input.hs
M src/Render.hs
M src/Types.hs
M src/main.c
M useragent.css
M rhapsode.cabal => rhapsode.cabal +2 -2
@@ 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:    

M src/CExports.hs => src/CExports.hs +89 -1
@@ 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

D src/Input.hs => src/Input.hs +0 -84
@@ 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

M src/Render.hs => src/Render.hs +30 -9
@@ 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"

M src/Types.hs => src/Types.hs +1 -41
@@ 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

M src/main.c => src/main.c +1 -0
@@ 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;

M useragent.css => useragent.css +1 -1
@@ 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