From 7909bac24b8f1e40d8f7614cab68095b8fedbeb5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Tue, 9 Jun 2020 17:51:14 +0200
Subject: [PATCH] Implement SVG reference checking

---
 src/Text/HTML/SanitizeXSS.hs | 33 +++++++++++++++++++++++++++++----
 test/main.hs                 | 12 ++++++++++++
 2 files changed, 41 insertions(+), 4 deletions(-)

diff --git a/src/Text/HTML/SanitizeXSS.hs b/src/Text/HTML/SanitizeXSS.hs
index 5eee7db..72b5f00 100644
--- a/src/Text/HTML/SanitizeXSS.hs
+++ b/src/Text/HTML/SanitizeXSS.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, TupleSections #-}
 -- | Sanatize HTML to prevent XSS attacks.
 --
 -- See README.md <http://github.com/gregwebs/haskell-xss-sanitize> for more details.
@@ -26,7 +26,7 @@ import Text.HTML.SanitizeXSS.Css
 import Text.HTML.TagSoup
 
 import Data.Set (Set(), member, notMember, (\\), fromList, fromAscList)
-import Data.Char ( toLower )
+import Data.Char (toLower, isSpace)
 import Data.Text (Text)
 import qualified Data.Text as T
 
@@ -36,6 +36,12 @@ import Codec.Binary.UTF8.String ( encodeString )
 
 import Data.Maybe (mapMaybe)
 
+import Data.Attoparsec.Text
+
+import Control.Applicative (many)
+import Data.Foldable (asum)
+import Control.Monad (guard)
+
 
 -- | Sanitize HTML to prevent XSS attacks.  This is equivalent to @filterTags safeTags@.
 sanitize :: Text -> Text
@@ -120,8 +126,27 @@ sanitizeAttribute :: (Text, Text) -> Maybe (Text, Text)
 sanitizeAttribute ("style", value) =
     let css = sanitizeCSS value
     in  if T.null css then Nothing else Just ("style", css)
-sanitizeAttribute attr | safeAttribute attr = Just attr
-                       | otherwise = Nothing
+sanitizeAttribute attr
+  | safeAttribute attr = Just attr
+sanitizeAttribute attr@(name, value)
+  | name `member` fromList svg_attr_val_allows_ref
+  , Right () <- parseOnly (unsafeSVGRef <* endOfInput) value
+  = Nothing
+  | name `member` fromList svg_attr_val_allows_ref
+  = Just attr
+sanitizeAttribute _ = Nothing
+
+unsafeSVGRef :: Parser ()
+unsafeSVGRef = do
+  skipMany space
+  string "url"
+  skipMany space
+  char '('
+  skipMany space
+  satisfy $ \x -> x /= '#' && not (isSpace x)
+  skipMany $ notChar ')'
+  char ')'
+  return ()
          
 
 -- | Returns @True@ if the specified URI is not a potential security risk.
diff --git a/test/main.hs b/test/main.hs
index 9b8eabb..dd5a833 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -109,3 +109,15 @@ main = hspec $ do
       sanitizedC custattr custattr
     it "filters non-custom attributes" $ do
       sanitizedC "<p weird=\"bar\"></p>" "<p></p>"
+
+  describe "svg escaping" $ do
+    it "does not filter simple values" $ do
+      let svg = "<circle fill=\"red\">"
+      sanitized svg svg
+    it "filters urls" $
+      sanitized "<circle fill=\"url(http://example.org)\">" "<circle>"
+    it "does not filter fragment urls" $ do
+      let svg = "<circle fill=\"url (  #foo  )\">"
+      sanitized svg svg
+    it "unescapes urls" $
+      sanitized "<circle fill=\"url&lpar;http://example.org&rpar;\">" "<circle>"