Add cabal file

.gitignore

@@ -4,4 +4,4 @@ dist
 .cabal-sandbox/
 cabal.sandbox.config
 .stack-work/
-xss-sanitize.cabal
+

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
@@ -60,18 +66,18 @@ balanceTags = balance []
 -- '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>
+    optMinimize = \x -> T.toLower x `member` voidElems -- <img><img> converts to <img />, <a/> converts to <a></a>
   } .  f . canonicalizeTags . parseTags
 
 voidElems :: Set T.Text
-voidElems = fromAscList $ T.words $ T.pack "area base br col command embed hr img input keygen link meta param source track wbr"
+voidElems = fromAscList . map T.toLower . T.words $ T.pack "area base br col command embed hr img input keygen link meta param source track wbr"
 
 balance :: [Text] -- ^ unclosed tags
         -> [Tag Text] -> [Tag Text]
-balance unclosed [] = map TagClose $ filter (`notMember` voidElems) unclosed
+balance unclosed [] = map TagClose $ filter (flip notMember voidElems . T.toLower) unclosed
 balance (x:xs) tags'@(TagClose name:tags)
     | x == name = TagClose name : balance xs tags
-    | x `member` voidElems = balance xs tags'
+    | T.toLower x `member` voidElems = balance xs tags'
     | otherwise = TagOpen name [] : TagClose name : balance (x:xs) tags
 balance unclosed (TagOpen name as : tags) =
     TagOpen name as : balance (name : unclosed) tags
@@ -109,19 +115,38 @@ safeTagsCustom safeName sanitizeAttr (TagOpen name attributes:tags)
 safeTagsCustom n a (t:tags) = t : safeTagsCustom n a tags
 
 safeTagName :: Text -> Bool
-safeTagName tagname = tagname `member` sanitaryTags
+safeTagName tagname = T.toLower tagname `member` sanitaryTags
 
 safeAttribute :: (Text, Text) -> Bool
-safeAttribute (name, value) = name `member` sanitaryAttributes &&
-  (name `notMember` uri_attributes || sanitaryURI value)
+safeAttribute (name, value) = T.toLower name `member` sanitaryAttributes &&
+  (T.toLower name `notMember` uri_attributes || sanitaryURI value)
 
 -- | low-level API if you have your own HTML parser. Used by safeTags.
 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)
+  | T.toLower name `member` fromList svg_attr_val_allows_ref
+  , Right () <- parseOnly (unsafeSVGRef <* endOfInput) value
+  = Nothing
+  | T.toLower name `member` fromList svg_attr_val_allows_ref
+  = Just attr
+sanitizeAttribute _ = Nothing
+
+unsafeSVGRef :: Parser ()
+unsafeSVGRef = do
+  skipMany space
+  asciiCI "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.
@@ -150,13 +175,13 @@ sanitaryAttributes = fromList (allowed_html_uri_attributes ++ acceptable_attribu
   \\ (fromList svg_attr_val_allows_ref) -- extra unescaping not implemented
 
 allowed_html_uri_attributes :: [Text]
-allowed_html_uri_attributes = ["href", "src", "cite", "action", "longdesc"]
+allowed_html_uri_attributes = map T.toLower ["href", "src", "cite", "action", "longdesc"]
 
 uri_attributes :: Set Text
-uri_attributes = fromList $ allowed_html_uri_attributes ++ ["xlink:href", "xml:base"]
+uri_attributes = fromList $ allowed_html_uri_attributes ++ map T.toLower ["xlink:href", "xml:base"]
 
 acceptable_elements :: [Text]
-acceptable_elements = ["a", "abbr", "acronym", "address", "area",
+acceptable_elements = map T.toLower ["a", "abbr", "acronym", "address", "area",
     "article", "aside", "audio", "b", "big", "blockquote", "br", "button",
     "canvas", "caption", "center", "cite", "code", "col", "colgroup",
     "command", "datagrid", "datalist", "dd", "del", "details", "dfn",
@@ -171,7 +196,7 @@ acceptable_elements = ["a", "abbr", "acronym", "address", "area",
     "u", "ul", "var", "video"]
   
 mathml_elements :: [Text]
-mathml_elements = ["maction", "math", "merror", "mfrac", "mi",
+mathml_elements = map T.toLower ["maction", "math", "merror", "mfrac", "mi",
     "mmultiscripts", "mn", "mo", "mover", "mpadded", "mphantom",
     "mprescripts", "mroot", "mrow", "mspace", "msqrt", "mstyle", "msub",
     "msubsup", "msup", "mtable", "mtd", "mtext", "mtr", "munder",
@@ -179,7 +204,7 @@ mathml_elements = ["maction", "math", "merror", "mfrac", "mi",
 
 -- this should include altGlyph I think
 svg_elements :: [Text]
-svg_elements = ["a", "animate", "animateColor", "animateMotion",
+svg_elements = map T.toLower ["a", "animate", "animateColor", "animateMotion",
     "animateTransform", "clipPath", "circle", "defs", "desc", "ellipse",
     "font-face", "font-face-name", "font-face-src", "g", "glyph", "hkern",
     "linearGradient", "line", "marker", "metadata", "missing-glyph",
@@ -187,7 +212,7 @@ svg_elements = ["a", "animate", "animateColor", "animateMotion",
     "set", "stop", "svg", "switch", "text", "title", "tspan", "use"]
   
 acceptable_attributes :: [Text]
-acceptable_attributes = ["abbr", "accept", "accept-charset", "accesskey",
+acceptable_attributes = map T.toLower ["abbr", "accept", "accept-charset", "accesskey",
     "align", "alt", "autocomplete", "autofocus", "axis",
     "background", "balance", "bgcolor", "bgproperties", "border",
     "bordercolor", "bordercolordark", "bordercolorlight", "bottompadding",
@@ -215,13 +240,13 @@ acceptable_attributes = ["abbr", "accept", "accept-charset", "accesskey",
     "width", "wrap", "xml:lang"]
 
 acceptable_protocols :: [String]
-acceptable_protocols = [ "ed2k", "ftp", "http", "https", "irc",
+acceptable_protocols = map (map toLower) [ "ed2k", "ftp", "http", "https", "irc",
     "mailto", "news", "gopher", "nntp", "telnet", "webcal",
     "xmpp", "callto", "feed", "urn", "aim", "rsync", "tag",
     "ssh", "sftp", "rtsp", "afs" ]
 
 mathml_attributes :: [Text]
-mathml_attributes = ["actiontype", "align", "columnalign", "columnalign",
+mathml_attributes = map T.toLower ["actiontype", "align", "columnalign", "columnalign",
     "columnalign", "columnlines", "columnspacing", "columnspan", "depth",
     "display", "displaystyle", "equalcolumns", "equalrows", "fence",
     "fontstyle", "fontweight", "frame", "height", "linethickness", "lspace",
@@ -232,7 +257,7 @@ mathml_attributes = ["actiontype", "align", "columnalign", "columnalign",
     "xlink:type", "xmlns", "xmlns:xlink"]
 
 svg_attributes :: [Text]
-svg_attributes = ["accent-height", "accumulate", "additive", "alphabetic",
+svg_attributes = map T.toLower ["accent-height", "accumulate", "additive", "alphabetic",
     "arabic-form", "ascent", "attributeName", "attributeType",
     "baseProfile", "bbox", "begin", "by", "calcMode", "cap-height",
     "class", "clip-path", "color", "color-rendering", "content", "cx",
@@ -263,12 +288,12 @@ svg_attributes = ["accent-height", "accumulate", "additive", "alphabetic",
 
 -- the values for these need to be escaped
 svg_attr_val_allows_ref :: [Text]
-svg_attr_val_allows_ref = ["clip-path", "color-profile", "cursor", "fill",
+svg_attr_val_allows_ref = map T.toLower ["clip-path", "color-profile", "cursor", "fill",
     "filter", "marker", "marker-start", "marker-mid", "marker-end",
     "mask", "stroke"]
 
 svg_allow_local_href :: [Text]
-svg_allow_local_href = ["altGlyph", "animate", "animateColor",
+svg_allow_local_href = map T.toLower ["altGlyph", "animate", "animateColor",
     "animateMotion", "animateTransform", "cursor", "feImage", "filter",
     "linearGradient", "pattern", "radialGradient", "textpath", "tref",
     "set", "use"]

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

xss-sanitize.cabal

@@ -0,0 +1,71 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.33.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: ede14cd4a2004a36fc4ccbcc4744dd07fa840331e09d4add9589665a71512bda
+
+name:           xss-sanitize
+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 more details
+category:       Web
+stability:      Stable
+homepage:       https://github.com/yesodweb/haskell-xss-sanitize#readme
+bug-reports:    https://github.com/yesodweb/haskell-xss-sanitize/issues
+author:         Greg Weber <greg@gregweber.info>
+maintainer:     Michael Snoyman <michael@snoyman.com>
+license:        BSD2
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/yesodweb/haskell-xss-sanitize
+
+library
+  exposed-modules:
+      Text.HTML.SanitizeXSS
+  other-modules:
+      Text.HTML.SanitizeXSS.Css
+      Paths_xss_sanitize
+  hs-source-dirs:
+      src
+  build-depends:
+      attoparsec >=0.10.0.3 && <1
+    , base >=4.9.1 && <5
+    , containers
+    , css-text >=0.1.1 && <0.2
+    , network-uri >=2.6
+    , tagsoup >=0.12.2 && <1
+    , text >=0.11 && <2
+    , utf8-string >=0.3 && <1.1
+  default-language: Haskell2010
+
+test-suite test
+  type: exitcode-stdio-1.0
+  main-is: main.hs
+  other-modules:
+      Text.HTML.SanitizeXSS
+      Text.HTML.SanitizeXSS.Css
+      Paths_xss_sanitize
+  hs-source-dirs:
+      test
+      src
+  cpp-options: -DTEST
+  build-depends:
+      HUnit >=1.2
+    , attoparsec >=0.10.0.3 && <1
+    , base >=4.9.1 && <5
+    , containers
+    , css-text >=0.1.1 && <0.2
+    , hspec >=1.3
+    , network-uri >=2.6
+    , tagsoup >=0.12.2 && <1
+    , text >=0.11 && <2
+    , utf8-string >=0.3 && <1.1
+  default-language: Haskell2010