From d6a13c9b0b25e52555f88e475a5ae09de4dcf456 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 4 Jan 2021 09:29:25 +1300
Subject: [PATCH] Persist alternate styles per-domain

---
 src/Input.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 44 insertions(+), 8 deletions(-)

diff --git a/src/Input.hs b/src/Input.hs
index 8adf070..6c745fc 100644
--- a/src/Input.hs
+++ b/src/Input.hs
@@ -5,6 +5,7 @@ module Input(fetchDocument, pageForText, applyCSScharset) where
 
 import           Data.Text.Lazy (fromStrict)
 import qualified Data.Text as Txt
+import qualified Data.Text.IO as Txt
 import           Data.Text.Encoding
 import qualified Data.Text.Lazy as LTxt
 import qualified Data.ByteString.Lazy as B
@@ -74,14 +75,35 @@ parseDocument _ _ (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':
     pageForDoc uri $ parseGemini (Just lang) $ utf8' bytes
 parseDocument _ _ (uri, "text/gemini", Left text) = pageForDoc uri $ parseGemini Nothing text
 parseDocument _ _ (uri, "text/gemini", Right bytes) = pageForDoc uri $ parseGemini Nothing $ utf8' bytes
-parseDocument referer _ (uri, "text/css", Left text) = return referer {
-        Types.url = uri,
-        css = parseForURL (conditionalStyles uri "document") uri text
+parseDocument referer _ (uri, "text/css", Left text)
+  | uri'@URI {uriAuthority = Just host} <- Types.url referer = do
+    -- Save this per-domain setting
+    dir <- (</> "domain") <$> getXdgDirectory XdgConfig "rhapsode"
+    createDirectoryIfMissing True dir
+    let header = Txt.pack (uriToString id uri "") `Txt.append` "\n" 
+    Txt.writeFile (dir </> uriRegName host) $ Txt.append header text
+
+    return referer {
+        css = parseForURL (conditionalStyles uri' "document") uri text
+    }
+  | otherwise = return referer {
+        css = parseForURL (conditionalStyles (Types.url referer) "document") uri text
+    }
+parseDocument referer _ (uri, "text/css", Right bytes)
+  | uri'@URI {uriAuthority = Just host} <- Types.url referer = do
+    -- Save this per-domain setting
+    dir <- (</> "domain") <$> getXdgDirectory XdgConfig "rhapsode"
+    createDirectoryIfMissing True dir
+    let header = Txt.pack (uriToString id uri "") `Txt.append` "\n" 
+    Txt.writeFile (dir </> uriRegName host) $ Txt.append header text
+
+    return referer {
+        css = parseForURL (conditionalStyles uri' "document") uri text
     }
-parseDocument referer _ (uri, "text/css", Right bytes) = return referer {
-        Types.url = uri,
-        css = parseForURL (conditionalStyles uri "document") uri text
-    } where text = applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes
+  | otherwise = return referer {
+        css = parseForURL (conditionalStyles (Types.url referer) "document") uri text
+    }
+  where text = applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes
 
 parseDocument ref sess (uri, mime, body) | mime' /= mime = parseDocument ref sess (uri, mime', body)
     where mime' = takeWhile (/= ';') mime
@@ -111,8 +133,22 @@ pageForText uri txt = pageForDoc uri XML.Document {
     }
 
 pageForDoc uri doc = do
+    -- See if the user has configured an alternate stylesheet for this domain.
+    let authorStyle = return $ html2css doc uri
+    styles <- case uriAuthority uri of
+        Nothing -> authorStyle
+        Just host -> do
+            dir <- getXdgDirectory XdgConfig "rhapsode"
+            let path = dir </> "domain" </> uriRegName host
+            hasAltStyle <- doesFileExist path
+            if not hasAltStyle then authorStyle else do
+                conf <- Txt.readFile path
+                let (uriTxt, css) = Txt.break (== '\n') conf
+                let uri' = fromMaybe nullURI $ parseAbsoluteURI $ Txt.unpack uriTxt
+                return $ parseForURL (conditionalStyles uri "document") uri' css
+
     hist <- newEmptyMVar
-    return Page {Types.url = uri, html = doc, css = html2css doc uri,
+    return Page {Types.url = uri, html = doc, css = styles,
         -- These fields are all blank, to be filled in later by logHistory & parseDocument'
         pageTitle = "", pageMIME = "", apps = [],
         backStack = [], forwardStack = [], visitedURLs = hist}
-- 
2.30.2