~alcinnz/rhapsode

ref: 95cb9bfbe0037a3087fcbbc96f38455fddcc1a7e rhapsode/src/Main.hs -rw-r--r-- 2.2 KiB
95cb9bfb — Adrian Cochrane Locate all relevent CSS. 5 years ago
                                                                                
95cb9bfb Adrian Cochrane
7523fb56 Adrian Cochrane
18bd686d Adrian Cochrane
95cb9bfb Adrian Cochrane
18bd686d Adrian Cochrane
95cb9bfb Adrian Cochrane
18bd686d Adrian Cochrane
95cb9bfb Adrian Cochrane
18bd686d Adrian Cochrane
7523fb56 Adrian Cochrane
18bd686d Adrian Cochrane
95cb9bfb 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
{-# 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           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 Data.ByteString.Lazy.UTF8 (toString)

import DefaultCSS

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 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 (toString (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 [] = ""