From 075aa68d0d2b933488fec2d7244f6b1571ae330e Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 29 Apr 2020 20:08:06 +1200 Subject: [PATCH] Extend MIMEtype dispatch to support alternative stylesheets. --- src/Input.hs | 68 +++++++++++++++++++++++++++++++++++++-------------- src/Render.hs | 13 +--------- 2 files changed, 50 insertions(+), 31 deletions(-) diff --git a/src/Input.hs b/src/Input.hs index 11a55b0..9ba75f9 100644 --- a/src/Input.hs +++ b/src/Input.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 diff --git a/src/Render.hs b/src/Render.hs index 3f0d10d..f85bca2 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -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 -- 2.30.2