Merge pull request #18 from zoominsoftware/customize

Allow customized whitelists.

package.yaml

@@ -1,5 +1,5 @@
 name:        xss-sanitize
-version:     0.3.5.7
+version:     0.3.6
 synopsis:    sanitize untrusted HTML to prevent XSS attacks
 description: run untrusted HTML through Text.HTML.SanitizeXSS.sanitizeXSS to prevent
   XSS attacks. see README.md <http://github.com/yesodweb/haskell-xss-sanitize> for

src/Text/HTML/SanitizeXSS.hs

@@ -12,6 +12,7 @@ module Text.HTML.SanitizeXSS
     -- * Custom filtering
     , filterTags
     , safeTags
+    , safeTagsCustom
     , balanceTags
 
     -- * Utilities
@@ -33,7 +34,7 @@ import Network.URI ( parseURIReference, URI (..),
                      isAllowedInURI, escapeURIString, uriScheme )
 import Codec.Binary.UTF8.String ( encodeString )
 
-import Data.Maybe (catMaybes)
+import Data.Maybe (mapMaybe)
 
 
 -- | Sanitize HTML to prevent XSS attacks.  This is equivalent to @filterTags safeTags@.
@@ -53,8 +54,10 @@ sanitizeBalance = filterTags (balanceTags . safeTags)
 balanceTags :: [Tag Text] -> [Tag Text]
 balanceTags = balance []
 
--- | Parse the given text to a list of tags, apply the given filtering function, and render back to HTML.
---   You can insert your own custom filtering but make sure you compose your filtering function with 'safeTags'!
+-- | Parse the given text to a list of tags, apply the given filtering
+-- function, and render back to HTML. You can insert your own custom
+-- filtering, but make sure you compose your filtering function with
+-- 'safeTags' or 'safeTagsCustom'.
 filterTags :: ([Tag Text] -> [Tag Text]) -> Text -> Text
 filterTags f = renderTagsOptions renderOptions {
     optMinimize = \x -> x `member` voidElems -- <img><img> converts to <img />, <a/> converts to <a></a>
@@ -74,17 +77,36 @@ balance unclosed (TagOpen name as : tags) =
     TagOpen name as : balance (name : unclosed) tags
 balance unclosed (t:ts) = t : balance unclosed ts
 
--- | Filters out any usafe tags and attributes. Use with filterTags to create a custom filter.
+-- | Filters out unsafe tags and sanitizes attributes. Use with
+-- filterTags to create a custom filter.
 safeTags :: [Tag Text] -> [Tag Text]
-safeTags [] = []
-safeTags (t@(TagClose name):tags)
-    | safeTagName name = t : safeTags tags
-    | otherwise = safeTags tags
-safeTags (TagOpen name attributes:tags)
-  | safeTagName name = TagOpen name
-      (catMaybes $ map sanitizeAttribute attributes) : safeTags tags
-  | otherwise = safeTags tags
-safeTags (t:tags) = t:safeTags tags
+safeTags = safeTagsCustom safeTagName sanitizeAttribute
+
+-- | Filters out unsafe tags and sanitizes attributes, like
+-- 'safeTags', but uses custom functions for determining which tags
+-- are safe and for sanitizing attributes. This allows you to add or
+-- remove specific tags or attributes on the white list, or to use
+-- your own white list.
+--
+-- @safeTagsCustom safeTagName sanitizeAttribute@ is equivalent to
+-- 'safeTags'.
+--
+-- @since 0.3.6
+safeTagsCustom ::
+     (Text -> Bool)                       -- ^ Select safe tags, like
+                                          -- 'safeTagName'
+  -> ((Text, Text) -> Maybe (Text, Text)) -- ^ Sanitize attributes,
+                                          -- like 'sanitizeAttribute'
+  -> [Tag Text] -> [Tag Text]
+safeTagsCustom _ _ [] = []
+safeTagsCustom safeName sanitizeAttr (t@(TagClose name):tags)
+    | safeName name = t : safeTagsCustom safeName sanitizeAttr tags
+    | otherwise = safeTagsCustom safeName sanitizeAttr tags
+safeTagsCustom safeName sanitizeAttr (TagOpen name attributes:tags)
+  | safeName name = TagOpen name (mapMaybe sanitizeAttr attributes) :
+      safeTagsCustom safeName sanitizeAttr tags
+  | otherwise = safeTagsCustom safeName sanitizeAttr tags
+safeTagsCustom n a (t:tags) = t : safeTagsCustom n a tags
 
 safeTagName :: Text -> Bool
 safeTagName tagname = tagname `member` sanitaryTags

test/main.hs

@@ -11,9 +11,19 @@ test f actual expected = do
   let result = f actual
   result @?= expected
 
-sanitized :: Text -> Text -> Expectation
+sanitized, sanitizedB, sanitizedC :: Text -> Text -> Expectation
 sanitized = test sanitize
 sanitizedB = test sanitizeBalance
+sanitizedC = test sanitizeCustom
+
+sanitizeCustom :: Text -> Text
+sanitizeCustom = filterTags $ safeTagsCustom mySafeName mySanitizeAttr
+  where
+    mySafeName t = t `elem` myTags || safeTagName t
+    mySanitizeAttr (key, val) | key `elem` myAttrs = Just (key, val)
+    mySanitizeAttr x = sanitizeAttribute x
+    myTags = ["custtag"]
+    myAttrs = ["custattr"]
 
 main :: IO ()
 main = hspec $ do
@@ -87,3 +97,15 @@ main = hspec $ do
       sanitizedB "<img></img>" "<img />"
     it "interleaved" $
       sanitizedB "<i>hello<b>world</i>" "<i>hello<b>world<i></i></b></i>"
+
+  describe "customized white list" $ do
+    it "does not filter custom tags" $ do
+      let custtag = "<p><custtag></custtag></p>"
+      sanitizedC custtag custtag
+    it "filters non-custom tags" $ do
+      sanitizedC "<p><weird></weird></p>" "<p></p>"
+    it "does not filter custom attributes" $ do
+      let custattr = "<p custattr=\"foo\"></p>"
+      sanitizedC custattr custattr
+    it "filters non-custom attributes" $ do
+      sanitizedC "<p weird=\"bar\"></p>" "<p></p>"