From dc7809767970bbbcd9cb8606b952c6d0acff47c0 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 19 Apr 2020 10:30:58 +1200
Subject: [PATCH] Provide utilities for rewriting CSS-referenced URLs.

---
 src/Data/CSS/Preprocessor/Assets.hs | 44 +++++++++++++++++++++++++++++
 stylist.cabal                       |  5 +++-
 2 files changed, 48 insertions(+), 1 deletion(-)
 create mode 100644 src/Data/CSS/Preprocessor/Assets.hs

diff --git a/src/Data/CSS/Preprocessor/Assets.hs b/src/Data/CSS/Preprocessor/Assets.hs
new file mode 100644
index 0000000..b880a7b
--- /dev/null
+++ b/src/Data/CSS/Preprocessor/Assets.hs
@@ -0,0 +1,44 @@
+module Data.CSS.Preprocessor.Assets(StyleAssets(..), URIRewriter) where
+
+-- TODO Unit test!
+import           Data.Text as Txt
+import           Network.URI
+import qualified Data.CSS.Syntax.StyleSheet as CSS
+import qualified Data.CSS.Syntax.Tokens as CSSTok
+
+-- | Extracts referenced URLs from specified properties.
+data StyleAssets = StyleAssets {
+    -- | The properties from which to extract URLs.
+    filterProps :: [Txt.Text],
+    -- | The extracted URLs.
+    assets :: [URI]
+}
+
+instance CSS.StyleSheet StyleAssets where
+    addRule (StyleAssets filterProps self) (CSS.StyleRule _ props _) =
+        StyleAssets filterProps $ nub (
+            self ++ [uri | (prop, val) <- props,
+                    prop `elem` filterProps,
+                    CSSTok.Url text <- val,
+                    Just uri <- [parseAbsoluteURI $ Txt.unpack text]]
+            )
+
+
+-- | Substitutes in given URLs into a property value.
+rewritePropertyVal rewrites (CSSTok.Url text:vals)
+    | Just uri <- parseURIReference $ Txt.unpack text, Just rewrite <- uri `M.lookup` rewrites =
+        CSSTok.Url (Txt.pack $ uriToString id rewrite "") : rewritePropertyVal rewrites vals
+    | otherwise = CSSTok.Url "" : rewritePropertyVal rewrites vals
+rewritePropertyVal rewrites (val:vals) = val:rewritePropertyVal rewrites vals
+rewritePropertyVal _ [] = []
+
+-- | Substitutes in given URLs into the inner stylesheet being parsed.
+data URIRewriter s = URIRewriter (M.Map URI URI) s
+instance CSS.StyleSheet s => CSS.StyleSheet (URIRewriter s) where
+    setPriority p (URIRewriter r s) = URIRewriter r $ CSS.setPriority p s
+    addRule (URIRewriter r s) (CSS.StyleRule sel props psuedo) =
+        URIRewriter r $ CSS.addRule s $ CSS.StyleRule sel [
+            (prop, rewritePropertyVal r val) | (prop, val) <- props
+        ] psuedo
+    addAtRule (URIRewriter r s) name toks =
+        let (self', toks') = CSS.addAtRule s name toks in (URIRewriter r s, toks)
diff --git a/stylist.cabal b/stylist.cabal
index f58e34c..8bbd0d2 100644
--- a/stylist.cabal
+++ b/stylist.cabal
@@ -53,7 +53,10 @@ source-repository head
 
 library
   -- Modules exported by the library.
-  exposed-modules:     Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style, Data.CSS.Preprocessor.Conditions, Data.CSS.Preprocessor.Conditions.Expr
+  exposed-modules:     Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector,
+                       Data.CSS.Style,
+                       Data.CSS.Preprocessor.Conditions, Data.CSS.Preprocessor.Conditions.Expr,
+                       Data.CSS.Preprocessor.Assets
   
   -- Modules included in this library but not exported.
   other-modules:       Data.CSS.Syntax.StylishUtil,
-- 
2.30.2