2 files changed, 50 insertions(+), 31 deletions(-)

M src/Input.hs
M src/Render.hs

@@ 1,7 1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PatternSynonyms, ViewPatterns #-}
-module Input(fetchDocument, docForText) where
+module Input(fetchDocument, pageForText, applyCSScharset) where
 
 import           Data.Text.Lazy (fromStrict)
 import qualified Data.Text as Txt


@@ 15,6 15,11 @@ import           Network.URI.Fetch
 import           Network.URI.Charset
 import qualified Data.Map as M
 
+-- For alternative styles
+import qualified Data.CSS.Syntax.Tokens as CSSTok
+import Data.CSS.Syntax.StyleSheet
+import Data.CSS.Preprocessor.Conditions (conditionalStyles)
+
 import System.IO
 import System.IO.Temp
 import Data.Default.Class


@@ 30,29 35,37 @@ import Foreign.C.String
 
 utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes
 
-fetchDocument http mime uri = fetchURL' http mime uri >>= parseDocument http
-parseDocument sess (uri, "html/x-error\t", resp) = parseDocument sess (uri, "text/html", resp)
-parseDocument _ (_, "text/html", Left text) = return $ HTML.parseLT $ fromStrict text
-parseDocument _ (_, "text/html", Right bytes) = return $ HTML.parseLBS bytes
-parseDocument _ (_, "text/gemini", Left text) = return $ parseGemini text
-parseDocument _ (_, "text/gemini", Right bytes) = return $ parseGemini $ utf8' bytes
-
-parseDocument _ (_, _, Left text)
-    | Right doc <- XML.parseText def $ fromStrict text = return doc
-    | otherwise = return $ docForText text
-parseDocument _ (_, _, Right bytes) | Right doc <- XML.parseLBS def bytes = return doc
-parseDocument _ (_, 't':'e':'x':'t':'/':_, Right bytes) =
+fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument referer http
+parseDocument ref sess (uri, "html/x-error\t", resp) = parseDocument ref sess (uri, "text/html", resp)
+parseDocument _ _ (uri, "text/html", Left text) = pageForDoc uri $ HTML.parseLT $ fromStrict text
+parseDocument _ _ (uri, "text/html", Right bytes) = pageForDoc uri $ HTML.parseLBS bytes
+parseDocument _ _ (uri, "text/gemini", Left text) = pageForDoc uri $ parseGemini text
+parseDocument _ _ (uri, "text/gemini", Right bytes) = pageForDoc uri $ parseGemini $ utf8' bytes
+parseDocument referer _ (uri, "text/css", Left text) = return referer {
+        url = uri,
+        css = parseForURL (conditionalStyles uri "document") uri text
+    }
+parseDocument referer _ (uri, "text/css", Right bytes) = return referer {
+        url = uri,
+        css = parseForURL (conditionalStyles uri "document") uri text
+    } where text = applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes
+
+parseDocument _ _ (uri, _, Left text)
+    | Right doc <- XML.parseText def $ fromStrict text = pageForDoc uri doc
+    | otherwise = pageForText uri text
+parseDocument _ _ (uri, _, Right bytes) | Right doc <- XML.parseLBS def bytes = pageForDoc uri doc
+parseDocument _ _ (uri, 't':'e':'x':'t':'/':_, Right bytes) =
     -- charset wasn't specified, so assume utf-8.
-    return $ docForText $ utf8' bytes
-parseDocument sess resp@(_, mime, _) = do
+    pageForText uri $ utf8' bytes
+parseDocument _ sess resp@(uri, mime, _) = do
     dir <- getCurrentDirectory -- TODO find Downloads directory.
     ret <- saveDownload nullURI {
         uriScheme = "file:",
         uriAuthority = Just (URIAuth "" "" "")
     } dir resp >>= dispatchByMIME sess mime
-    return $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret
+    pageForDoc uri $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret
 
-docForText txt = XML.Document {
+pageForText uri txt = pageForDoc uri XML.Document {
         XML.documentPrologue = XML.Prologue [] Nothing [],
         XML.documentRoot = XML.Element {
             XML.elementName = "pre",


@@ 62,6 75,23 @@ docForText txt = XML.Document {
         XML.documentEpilogue = []
     }
 
+pageForDoc uri doc = return Page {url = uri, html = doc, css = html2css doc uri}
+
+--------
+---- CSS charset sniffing
+--------
+applyCSScharset (charset:charsets) bytes
+        | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text
+        | otherwise = applyCSScharset charsets bytes
+    where
+        text = convertCharset charset bytes
+applyCSScharset _ bytes = convertCharset "utf-8" bytes
+cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks,
+        (CSSTok.String charset:_) <- skipCSSspace toks' = charset
+    | otherwise = ""
+skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks
+skipCSSspace toks = toks
+
 --------
 ---- Gemini implementation
 --------


@@ 135,5 165,5 @@ c_fetchURL c_session c_mimes c_referer c_uri = do
     referer <- deRefStablePtr c_referer
     uri <- peekCString c_uri
     let uri' = nullURI `fromMaybe` parseURIReference uri `relativeTo` url referer
-    doc <- fetchDocument session (words mimes) uri'
-    newStablePtr $ Page {url = uri', html = doc, css = html2css doc uri'}
+    doc <- fetchDocument session referer (words mimes) uri'
+    newStablePtr doc

@@ 37,6 37,7 @@ import           Control.Exception (catch)
 -- Internal Rhapsode Subcomponents
 import SpeechStyle
 import SSML
+import Input (applyCSScharset)
 
 -- C API
 import Types


@@ 86,18 87,6 @@ lowerVars "-rhapsode" = CSSCond.B True
 lowerVars _ = CSSCond.B False
 lowerToks _ = CSSCond.B False
 
-applyCSScharset (charset:charsets) bytes
-        | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text
-        | otherwise = applyCSScharset charsets bytes
-    where
-        text = convertCharset charset bytes
-applyCSScharset _ bytes = convertCharset "utf-8" bytes
-cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks,
-        (CSSTok.String charset:_) <- skipCSSspace toks' = charset
-    | otherwise = ""
-skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks
-skipCSSspace toks = toks
-
 loadUserStyles styles = do
     dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode"
     exists <- Dir.doesDirectoryExist dir