From aea2a653354f36bac3216a0d5f6c6806f7a1eec8 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 13 Jul 2019 16:31:35 +1200 Subject: [PATCH] Locate all relevent CSS. --- rhapsode.cabal | 5 ++- src/Main.hs | 47 +++++++++++++++++++++- user-agent.css | 103 ------------------------------------------------- 3 files changed, 49 insertions(+), 106 deletions(-) delete mode 100644 user-agent.css diff --git a/rhapsode.cabal b/rhapsode.cabal index 3e94374..4c3e2a9 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -60,7 +60,10 @@ executable rhapsode -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10, http-client, http-client-tls, bytestring + build-depends: base >=4.9 && <4.10, + http-client, http-client-tls, bytestring, + html-conduit, xml-conduit, text, containers, + network-uri -- Directories containing source files. hs-source-dirs: src diff --git a/src/Main.hs b/src/Main.hs index 192efd4..924cc2d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where import System.Environment import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client.Internal import qualified Network.HTTP.Client.TLS as TLS -import qualified Data.ByteString.Lazy as Bytes +import Network.URI +import qualified Text.HTML.DOM as HTML +import qualified Text.XML as XML +import Data.Text (unpack) +import qualified Data.Map as M +import qualified Data.ByteString.Lazy.Char8 as C8 +import DefaultCSS main :: IO () main = do @@ -14,4 +22,39 @@ main = do request <- HTTP.parseRequest url manager <- HTTP.newManager TLS.tlsManagerSettings response <- HTTP.httpLbs request manager - Bytes.putStrLn $ HTTP.responseBody response + let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response + style <- retreiveStyles html manager request + putStrLn $ unlines style + +retreiveStyles html manager base = do + css <- externalStyles html manager base + return $ userAgentCSS : css ++ internalStyles html + +externalStyles html manager base = go $ linkedStyles html + where -- TODO parallelise loads + go (link:links) = do + request <- setUriRelative base link + response <- HTTP.httpLbs request manager + rest <- go links + return (C8.unpack (HTTP.responseBody response) : rest) + go [] = return [] + +linkedStyles (XML.Element "link" attrs _) + | Just link <- "href" `M.lookup` attrs, + Just "stylesheet" <- "rel" `M.lookup` attrs, + Just uri <- parseURIReference $ unpack link = [uri] +linkedStyles (XML.Element _ _ children) = + concat [linkedStyles el | XML.NodeElement el <- children] + +internalStyles (XML.Element "style" _ children) = [strContent children] +internalStyles (XML.Element _ _ children) = + concat [internalStyles el | XML.NodeElement el <- children] + + +strContent (XML.NodeContent text : rest) = unpack text ++ strContent rest +-- We do want to read in comments for CSS, just not for display. +strContent (XML.NodeComment text : rest) = unpack text ++ strContent rest +strContent (XML.NodeElement (XML.Element _ _ children):rest) = + strContent children ++ strContent rest +strContent (_:rest) = strContent rest +strContent [] = "" diff --git a/user-agent.css b/user-agent.css deleted file mode 100644 index 71d0eb7..0000000 --- a/user-agent.css +++ /dev/null @@ -1,103 +0,0 @@ -head, link, meta, style, script, title, base {speak: never} -datalist, template {speak: never} - -/** Forms **/ -/* Hide buttons that don't do anything */ -button[type=button] {speak: never} -button[formaction] {speak: always} - -button::before, input[type=button]::before, input[type=submit]::before { - content: "Button"; - pitch: high; -} -select::before, textarea::before, input::before {content: "Input"; pitch: high} -output::before {content: "Output"; pitch: high} -text-area, button, select, input, output {pitch: low} -input, output {content: attr(value)} -text-area {speak-as: literal-punctuation} - -option:not([checked]) {speak: never} -select[multiple] option {cue-before: url(bulletpoint.wav)} - -/* Forms themselves require a label in order to support navigation */ -form::before {content: "Form"} -form[action]::before {content: attr(action)} -form[alt]::before {content: attr(alt)} -form[title]::before {content: attr(title)} - -/** 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} -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 {pitch: high} - -/** Text **/ -hr {pause: x-strong} -p, pre, samp, blockquote {pause: strong} -pre, address, samp {speak-as: literal-punctuation} - -:link {cue-before: url(link.wav); voice-rate: slow} -:link:visited {cue-before: url(link.wav) -1db} - -b, strong {voice-rate: x-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 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-ol1} -ol ol {counter-reset: -rhaps-ol2} -ol ol ol {counter-reset: -rhaps-ol3} -ol ol ol ol {counter-reset: -rhaps-ol4} -ol ol ol ol ol {counter-reset: -rhaps-ol5} -ol ol ol ol ol ol {counter-reset: -rhaps-ol6} -ol li::before {content: counter(-rhaps-ol1)} -ol ol li::before {content: counters(-rhaps-ol1, -rhaps-ol2)} -ol ol ol li::before {content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3)} -ol ol ol ol li::before { - content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4) -} -ol ol ol ol ol li::before { - content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5) -} -ol ol ol ol ol ol li::before { - content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5, -rhaps-ol6) -} - - -/** HTML6 **/ -abbr[title]::after {content: attr(title); voice-volume: x-soft} -abbr {speak-as: spell-out} - -q, blockquote {voice-family: neutral 2} -cite {voice-stress: reduce} -dialog:not([open]) {speak: never} -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} \ No newline at end of file -- 2.30.2