~alcinnz/rhapsode

ref: 7157dd647e870dd74af90f0ba02534b9054c33bc rhapsode/src/Main.hs -rw-r--r-- 2.6 KiB
7157dd64 — Adrian Cochrane Fix counters parsing & usage. 5 years ago
                                                                                
aea2a653 Adrian Cochrane
7523fb56 Adrian Cochrane
18bd686d Adrian Cochrane
eddbb26a Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
a59899dd Adrian Cochrane
aea2a653 Adrian Cochrane
eddbb26a Adrian Cochrane
a59899dd Adrian Cochrane
10988819 Adrian Cochrane
a59899dd Adrian Cochrane
10988819 Adrian Cochrane
f1a311bd Adrian Cochrane
2adc7fb2 Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
eddbb26a Adrian Cochrane
5b9b03db Adrian Cochrane
18bd686d Adrian Cochrane
7523fb56 Adrian Cochrane
18bd686d Adrian Cochrane
aea2a653 Adrian Cochrane
2adc7fb2 Adrian Cochrane
eddbb26a Adrian Cochrane
a59899dd Adrian Cochrane
5b9b03db Adrian Cochrane
aea2a653 Adrian Cochrane
2adc7fb2 Adrian Cochrane
53b9d822 Adrian Cochrane
a59899dd Adrian Cochrane
eddbb26a Adrian Cochrane
10988819 Adrian Cochrane
2adc7fb2 Adrian Cochrane
aea2a653 Adrian Cochrane
10988819 Adrian Cochrane
2adc7fb2 Adrian Cochrane
10988819 Adrian Cochrane
aea2a653 Adrian Cochrane
afbc3c05 Adrian Cochrane
a59899dd Adrian Cochrane
2adc7fb2 Adrian Cochrane
10988819 Adrian Cochrane
2adc7fb2 Adrian Cochrane
eddbb26a Adrian Cochrane
2adc7fb2 Adrian Cochrane
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
{-# LANGUAGE OverloadedStrings #-}
module Main where

import System.Environment
import Data.Char (isSpace)

import qualified Network.HTTP.Client as HTTP
import           Network.HTTP.Client.Internal
import qualified Network.HTTP.Client.TLS as TLS
import           Network.URI
import qualified Data.ByteString.Lazy.Char8 as C8

import qualified Text.HTML.DOM as HTML
import qualified Text.XML as XML
import           Data.Text as Txt (pack, unpack, Text(..), append,
        words, unwords, head, last, stripStart, stripEnd)

import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Style as Style
import qualified Data.CSS.Syntax.Tokens as CSSTok
import qualified Data.HTML2CSS as H2C

import qualified Data.List as L
import qualified Data.Map as M
import Data.Scientific (toRealFloat)
import Data.Maybe (fromJust)

import DefaultCSS
import StyleTree
import SSML

main :: IO ()
main = do
    url:_ <- getArgs
    -- TODO support more URI schemes, and do nonblocking networking. This could be it's own module.
    request <- HTTP.parseRequest url
    manager <- HTTP.newManager TLS.tlsManagerSettings
    response <- HTTP.httpLbs request manager
    let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response
    style <- retreiveStyles html manager $ fromJust $ parseURI url
    let transcript = stylize style html
    C8.putStrLn $ renderElLBS $ styleToSSML transcript

renderElLBS el = XML.renderLBS XML.def $ XML.Document {
        XML.documentPrologue = XML.Prologue [] Nothing [],
        XML.documentRoot = el,
        XML.documentEpilogue = []
    }

retreiveStyles html manager base = do
    style <- H2C.externalStylesForURL authorStyle testMedia html base loadURL
    return style
  where
    emptyStyle :: Style.QueryableStyleSheet StyleTree
    emptyStyle = Style.queryableStyleSheet
    agentStyle = H2C.cssPriorityAgent emptyStyle `CSS.parse` Txt.pack userAgentCSS
    authorStyle = H2C.internalStylesForURL testMedia agentStyle base html

    loadURL url = do -- TODO parallelise.
        request <- requestFromURI url
        response <- HTTP.httpLbs request manager
        return $ Txt.pack $ C8.unpack $ HTTP.responseBody response

testMedia attrs = media == Nothing || media == Just "speech"
    where media = "media" `M.lookup` attrs


stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildText styles html
    where
        buildChild self _ | content self == [] = Nothing
            | otherwise = Just [Style.temp {content = content self}]
        buildNode self children = self {children = children}
        buildText _ txt = Style.temp {content = [Content txt]}