{-# 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 qualified Data.ByteString.Lazy.Char8 as C8

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 (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,
        testMedia attrs,
        Just uri <- parseURIReference $ unpack link = [uri]
linkedStyles (XML.Element _ _ children) =
    concat [linkedStyles el | XML.NodeElement el <- children]

internalStyles (XML.Element "style" attrs children)
    | testMedia attrs = [strContent children]
internalStyles (XML.Element _ _ children) =
    concat [internalStyles el | XML.NodeElement el <- children]

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


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