Implement SVG reference checking

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.

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>"