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