xss-sanitize 0.3.5.3 → 0.3.7.2
raw patch · 8 files changed
Files
- ChangeLog.md +15/−0
- README.md +3/−1
- Text/HTML/SanitizeXSS.hs +0/−266
- Text/HTML/SanitizeXSS/Css.hs +0/−140
- src/Text/HTML/SanitizeXSS.hs +311/−0
- src/Text/HTML/SanitizeXSS/Css.hs +140/−0
- test/main.hs +28/−1
- xss-sanitize.cabal +63/−53
+ ChangeLog.md view
@@ -0,0 +1,15 @@+# 0.3.7.2++Stops Tag Soup from escaping &"<> which breaks HTML entities++# 0.3.7.1++add max height and max width as valid style attributes++# 0.3.7++clear the contents of style and script tags instead of escaping them++# 0.3.5.6++expose safeTagName
README.md view
@@ -1,5 +1,7 @@ # Summary +[](https://github.com/yesodweb/haskell-xss-sanitize/actions/workflows/tests.yml)+ xss-sanitize allows you to accept html from untrusted sources by first filtering it through a white list. The white list filtering is fairly comprehensive, including support for css in style attributes, but there are limitations enumerated below. @@ -55,7 +57,7 @@ Ultimately this is where your security comes from. I would expect that a faulty white list would act as a strong deterrent, but this library strives for correctness. -The [source code of html5lib](http://code.google.com/p/html5lib/source/browse/python/html5lib/sanitizer.py) is the source of the white list and my implementation reference. If you feel a tag is missing from the white list, check to see if it has been added there.+The [source code of html5lib](https://github.com/html5lib/html5lib-python/blob/master/html5lib/filters/sanitizer.py) is the source of the white list and my implementation reference. If you feel a tag is missing from the white list, check to see if it has been added there. If anyone knows of better sources or thinks a particular tag/attribute/value may be vulnerable, please let me know. [HTML Purifier](http://htmlpurifier.org/live/smoketests/printDefinition.php) does have a more permissive and configurable (yet safe) white list if you are looking to add anything.
− Text/HTML/SanitizeXSS.hs
@@ -1,266 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Sanatize HTML to prevent XSS attacks.------ See README.md <http://github.com/gregwebs/haskell-xss-sanitize> for more details.-module Text.HTML.SanitizeXSS- (- -- * Sanitize- sanitize- , sanitizeBalance- , sanitizeXSS-- -- * Custom filtering- , filterTags- , safeTags- , balanceTags-- -- * Utilities- , sanitizeAttribute- , sanitaryURI- ) where--import Text.HTML.SanitizeXSS.Css--import Text.HTML.TagSoup--import Data.Set (Set(), member, notMember, (\\), fromList, fromAscList)-import Data.Char ( toLower )-import Data.Text (Text)-import qualified Data.Text as T--import Network.URI ( parseURIReference, URI (..),- isAllowedInURI, escapeURIString, uriScheme )-import Codec.Binary.UTF8.String ( encodeString )--import qualified Data.Map as Map-import Data.Maybe (catMaybes)----- | Sanitize HTML to prevent XSS attacks. This is equivalent to @filterTags safeTags@.-sanitize :: Text -> Text-sanitize = sanitizeXSS---- | alias of sanitize function-sanitizeXSS :: Text -> Text-sanitizeXSS = filterTags safeTags---- | Sanitize HTML to prevent XSS attacks and also make sure the tags are balanced.--- This is equivalent to @filterTags (balanceTags . safeTags)@.-sanitizeBalance :: Text -> Text-sanitizeBalance = filterTags (balanceTags . safeTags)---- | Filter which makes sure the tags are balanced. Use with 'filterTags' and 'safeTags' to create a custom filter.-balanceTags :: [Tag Text] -> [Tag Text]-balanceTags = balance Map.empty---- | 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'!-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>- } . 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"--balance :: Map.Map Text Int -> [Tag Text] -> [Tag Text]-balance m [] =- concatMap go $ Map.toList m- where- go (name, i)- | noClosing name = []- | otherwise = replicate i $ TagClose name- noClosing = flip member voidElems-balance m (t@(TagClose name):tags) =- case Map.lookup name m of- Nothing -> TagOpen name [] : TagClose name : balance m tags- Just i ->- let m' = if i == 1- then Map.delete name m- else Map.insert name (i - 1) m- in t : balance m' tags-balance m (TagOpen name as : tags) =- TagOpen name as : balance m' tags- where- m' = case Map.lookup name m of- Nothing -> Map.insert name 1 m- Just i -> Map.insert name (i + 1) m-balance m (t:ts) = t : balance m ts---- | Filters out any usafe tags and 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--safeTagName :: Text -> Bool-safeTagName tagname = tagname `member` sanitaryTags--safeAttribute :: (Text, Text) -> Bool-safeAttribute (name, value) = name `member` sanitaryAttributes &&- (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- ---- | Returns @True@ if the specified URI is not a potential security risk.-sanitaryURI :: Text -> Bool-sanitaryURI u =- case parseURIReference (escapeURI $ T.unpack u) of- Just p -> (null (uriScheme p)) ||- ((map toLower $ init $ uriScheme p) `member` safeURISchemes)- Nothing -> False----- | Escape unicode characters in a URI. Characters that are--- already valid in a URI, including % and ?, are left alone.-escapeURI :: String -> String-escapeURI = escapeURIString isAllowedInURI . encodeString--safeURISchemes :: Set String-safeURISchemes = fromList acceptable_protocols--sanitaryTags :: Set Text-sanitaryTags = fromList (acceptable_elements ++ mathml_elements ++ svg_elements)- \\ (fromList svg_allow_local_href) -- extra filtering not implemented--sanitaryAttributes :: Set Text-sanitaryAttributes = fromList (allowed_html_uri_attributes ++ acceptable_attributes ++ mathml_attributes ++ svg_attributes)- \\ (fromList svg_attr_val_allows_ref) -- extra unescaping not implemented--allowed_html_uri_attributes :: [Text]-allowed_html_uri_attributes = ["href", "src", "cite", "action", "longdesc"]--uri_attributes :: Set Text-uri_attributes = fromList $ allowed_html_uri_attributes ++ ["xlink:href", "xml:base"]--acceptable_elements :: [Text]-acceptable_elements = ["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",- "dialog", "dir", "div", "dl", "dt", "em", "event-source", "fieldset",- "figcaption", "figure", "footer", "font", "form", "header", "h1", "h2",- "h3", "h4", "h5", "h6", "hr", "i", "img", "input", "ins", "keygen",- "kbd", "label", "legend", "li", "m", "main", "map", "menu", "meter", "multicol",- "nav", "nextid", "ol", "output", "optgroup", "option", "p", "pre",- "progress", "q", "s", "samp", "section", "select", "small", "sound",- "source", "spacer", "span", "strike", "strong", "sub", "sup", "table",- "tbody", "td", "textarea", "time", "tfoot", "th", "thead", "tr", "tt",- "u", "ul", "var", "video"]- -mathml_elements :: [Text]-mathml_elements = ["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",- "munderover", "none"]---- this should include altGlyph I think-svg_elements :: [Text]-svg_elements = ["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",- "mpath", "path", "polygon", "polyline", "radialGradient", "rect",- "set", "stop", "svg", "switch", "text", "title", "tspan", "use"]- -acceptable_attributes :: [Text]-acceptable_attributes = ["abbr", "accept", "accept-charset", "accesskey",- "align", "alt", "autocomplete", "autofocus", "axis",- "background", "balance", "bgcolor", "bgproperties", "border",- "bordercolor", "bordercolordark", "bordercolorlight", "bottompadding",- "cellpadding", "cellspacing", "ch", "challenge", "char", "charoff",- "choff", "charset", "checked", "class", "clear", "color",- "cols", "colspan", "compact", "contenteditable", "controls", "coords",- -- "data", TODO: allow this with further filtering- "datafld", "datapagesize", "datasrc", "datetime", "default",- "delay", "dir", "disabled", "draggable", "dynsrc", "enctype", "end",- "face", "for", "form", "frame", "galleryimg", "gutter", "headers",- "height", "hidefocus", "hidden", "high", "hreflang", "hspace",- "icon", "id", "inputmode", "ismap", "keytype", "label", "leftspacing",- "lang", "list", "loop", "loopcount", "loopend",- "loopstart", "low", "lowsrc", "max", "maxlength", "media", "method",- "min", "multiple", "name", "nohref", "noshade", "nowrap", "open",- "optimum", "pattern", "ping", "point-size", "prompt", "pqg",- "radiogroup", "readonly", "rel", "repeat-max", "repeat-min",- "replace", "required", "rev", "rightspacing", "rows", "rowspan",- "rules", "scope", "selected", "shape", "size", "span", "start",- "step",- "style", -- gets further filtering- "summary", "suppress", "tabindex", "target",- "template", "title", "toppadding", "type", "unselectable", "usemap",- "urn", "valign", "value", "variable", "volume", "vspace", "vrml",- "width", "wrap", "xml:lang"]--acceptable_protocols :: [String]-acceptable_protocols = [ "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",- "columnalign", "columnlines", "columnspacing", "columnspan", "depth",- "display", "displaystyle", "equalcolumns", "equalrows", "fence",- "fontstyle", "fontweight", "frame", "height", "linethickness", "lspace",- "mathbackground", "mathcolor", "mathvariant", "mathvariant", "maxsize",- "minsize", "other", "rowalign", "rowalign", "rowalign", "rowlines",- "rowspacing", "rowspan", "rspace", "scriptlevel", "selection",- "separator", "stretchy", "width", "width", "xlink:href", "xlink:show",- "xlink:type", "xmlns", "xmlns:xlink"]--svg_attributes :: [Text]-svg_attributes = ["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",- "cy", "d", "dx", "dy", "descent", "display", "dur", "end", "fill",- "fill-opacity", "fill-rule", "font-family", "font-size",- "font-stretch", "font-style", "font-variant", "font-weight", "from",- "fx", "fy", "g1", "g2", "glyph-name", "gradientUnits", "hanging",- "height", "horiz-adv-x", "horiz-origin-x", "id", "ideographic", "k",- "keyPoints", "keySplines", "keyTimes", "lang", "marker-end",- "marker-mid", "marker-start", "markerHeight", "markerUnits",- "markerWidth", "mathematical", "max", "min", "name", "offset",- "opacity", "orient", "origin", "overline-position",- "overline-thickness", "panose-1", "path", "pathLength", "points",- "preserveAspectRatio", "r", "refX", "refY", "repeatCount",- "repeatDur", "requiredExtensions", "requiredFeatures", "restart",- "rotate", "rx", "ry", "slope", "stemh", "stemv", "stop-color",- "stop-opacity", "strikethrough-position", "strikethrough-thickness",- "stroke", "stroke-dasharray", "stroke-dashoffset", "stroke-linecap",- "stroke-linejoin", "stroke-miterlimit", "stroke-opacity",- "stroke-width", "systemLanguage", "target", "text-anchor", "to",- "transform", "type", "u1", "u2", "underline-position",- "underline-thickness", "unicode", "unicode-range", "units-per-em",- "values", "version", "viewBox", "visibility", "width", "widths", "x",- "x-height", "x1", "x2", "xlink:actuate", "xlink:arcrole",- "xlink:href", "xlink:role", "xlink:show", "xlink:title", "xlink:type",- "xml:base", "xml:lang", "xml:space", "xmlns", "xmlns:xlink", "y",- "y1", "y2", "zoomAndPan"]---- 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",- "filter", "marker", "marker-start", "marker-mid", "marker-end",- "mask", "stroke"]--svg_allow_local_href :: [Text]-svg_allow_local_href = ["altGlyph", "animate", "animateColor",- "animateMotion", "animateTransform", "cursor", "feImage", "filter",- "linearGradient", "pattern", "radialGradient", "textpath", "tref",- "set", "use"]-
− Text/HTML/SanitizeXSS/Css.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}-module Text.HTML.SanitizeXSS.Css (- sanitizeCSS-#ifdef TEST-, allowedCssAttributeValue-#endif- ) where--import Data.Text (Text)-import qualified Data.Text as T-import Data.Attoparsec.Text-import Data.Text.Lazy.Builder (toLazyText)-import Data.Text.Lazy (toStrict)-import Data.Set (member, fromList, Set)-import Data.Char (isDigit)-import Control.Applicative ((<|>), pure)-import Text.CSS.Render (renderAttrs)-import Text.CSS.Parse (parseAttrs)-import Prelude hiding (takeWhile)---- import FileLocation (debug, debugM)----- this is a direct translation from sanitizer.py, except--- sanitizer.py filters out url(), but this is redundant-sanitizeCSS :: Text -> Text-sanitizeCSS css = toStrict . toLazyText .- renderAttrs . filter isSanitaryAttr . filterUrl $ parseAttributes- where- filterUrl :: [(Text,Text)] -> [(Text,Text)]- filterUrl = map filterUrlAttribute- where- filterUrlAttribute :: (Text, Text) -> (Text, Text)- filterUrlAttribute (prop,value) =- case parseOnly rejectUrl value of- Left _ -> (prop,value)- Right noUrl -> filterUrlAttribute (prop, noUrl)-- rejectUrl = do- pre <- manyTill anyChar (string "url")- skipMany space- _<-char '('- skipWhile (/= ')')- _<-char ')'- rest <- takeText- return $ T.append (T.pack pre) rest--- parseAttributes = case parseAttrs css of- Left _ -> []- Right as -> as-- isSanitaryAttr (_, "") = False- isSanitaryAttr ("",_) = False- isSanitaryAttr (prop, value)- | prop `member` allowed_css_properties = True- | (T.takeWhile (/= '-') prop) `member` allowed_css_unit_properties &&- all allowedCssAttributeValue (T.words value) = True- | prop `member` allowed_svg_properties = True- | otherwise = False-- allowed_css_unit_properties :: Set Text- allowed_css_unit_properties = fromList ["background","border","margin","padding"]--allowedCssAttributeValue :: Text -> Bool-allowedCssAttributeValue val =- val `member` allowed_css_keywords ||- case parseOnly allowedCssAttributeParser val of- Left _ -> False- Right b -> b- where- allowedCssAttributeParser = do- rgb <|> hex <|> rgb <|> cssUnit-- aToF = fromList "abcdef"-- hex = do- _ <- char '#'- hx <- takeText- return $ T.all (\c -> isDigit c || (c `member` aToF)) hx-- -- should have used sepBy (symbol ",")- rgb = do- _<- string "rgb("- skipMany1 digit >> skipOk (== '%')- skip (== ',')- skipMany digit >> skipOk (== '%')- skip (== ',')- skipMany digit >> skipOk (== '%')- skip (== ')')- return True-- cssUnit = do- skip isDigit- skipOk isDigit- skipOk (== '.')- skipOk isDigit >> skipOk isDigit- skipSpace- unit <- takeText- return $ T.null unit || unit `member` allowed_css_attribute_value_units--skipOk :: (Char -> Bool) -> Parser ()-skipOk p = skip p <|> pure ()--allowed_css_attribute_value_units :: Set Text-allowed_css_attribute_value_units = fromList- [ "cm", "em", "ex", "in", "mm", "pc", "pt", "px", "%", ",", "\\"]--allowed_css_properties :: Set Text-allowed_css_properties = fromList acceptable_css_properties- where- acceptable_css_properties = ["azimuth", "background-color",- "border-bottom-color", "border-collapse", "border-color",- "border-left-color", "border-right-color", "border-top-color", "clear",- "color", "cursor", "direction", "display", "elevation", "float", "font",- "font-family", "font-size", "font-style", "font-variant", "font-weight",- "height", "letter-spacing", "line-height", "overflow", "pause",- "pause-after", "pause-before", "pitch", "pitch-range", "richness",- "speak", "speak-header", "speak-numeral", "speak-punctuation",- "speech-rate", "stress", "text-align", "text-decoration", "text-indent",- "unicode-bidi", "vertical-align", "voice-family", "volume",- "white-space", "width"]--allowed_css_keywords :: Set Text-allowed_css_keywords = fromList acceptable_css_keywords- where- acceptable_css_keywords = ["auto", "aqua", "black", "block", "blue",- "bold", "both", "bottom", "brown", "center", "collapse", "dashed",- "dotted", "fuchsia", "gray", "green", "!important", "italic", "left",- "lime", "maroon", "medium", "none", "navy", "normal", "nowrap", "olive",- "pointer", "purple", "red", "right", "solid", "silver", "teal", "top",- "transparent", "underline", "white", "yellow"]---- used in css filtering-allowed_svg_properties :: Set Text-allowed_svg_properties = fromList acceptable_svg_properties- where- acceptable_svg_properties = [ "fill", "fill-opacity", "fill-rule",- "stroke", "stroke-width", "stroke-linecap", "stroke-linejoin",- "stroke-opacity"]
+ src/Text/HTML/SanitizeXSS.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Sanatize HTML to prevent XSS attacks.+--+-- See README.md <http://github.com/gregwebs/haskell-xss-sanitize> for more details.+module Text.HTML.SanitizeXSS+ (+ -- * Sanitize+ sanitize+ , sanitizeBalance+ , sanitizeXSS++ -- * Custom filtering+ , filterTags+ , safeTags+ , safeTagsCustom+ , clearTags+ , clearTagsCustom+ , balanceTags++ -- * Utilities+ , safeTagName+ , sanitizeAttribute+ , sanitaryURI+ ) where++import Text.HTML.SanitizeXSS.Css++import Text.HTML.TagSoup++import Data.Set (Set(), member, notMember, (\\), fromList, fromAscList)+import Data.Char ( toLower )+import Data.Text (Text)+import qualified Data.Text as T++import Network.URI ( parseURIReference, URI (..),+ isAllowedInURI, escapeURIString, uriScheme )+import Codec.Binary.UTF8.String ( encodeString )++import Data.Maybe (mapMaybe)+++-- | Sanitize HTML to prevent XSS attacks. This is equivalent to @filterTags safeTags@.+sanitize :: Text -> Text+sanitize = sanitizeXSS++-- | alias of sanitize function+sanitizeXSS :: Text -> Text+sanitizeXSS = filterTags (safeTags . clearTags)++-- | Sanitize HTML to prevent XSS attacks and also make sure the tags are balanced.+-- This is equivalent to @filterTags (balanceTags . safeTags)@.+sanitizeBalance :: Text -> Text+sanitizeBalance = filterTags (balanceTags . safeTags . clearTags)++-- | Filter which makes sure the tags are balanced. Use with 'filterTags' and 'safeTags' to create a custom filter.+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' and 'clearTags' or 'safeTagsCustom' and 'clearTagsCustom'.+filterTags :: ([Tag Text] -> [Tag Text]) -> Text -> Text+filterTags f = renderTagsOptions renderOptions {+ optEscape = id -- stops &"<> from being escaped which breaks existing HTML entities+ , optMinimize = \x -> x `member` voidElems -- <img><img> converts to <img />, <a/> converts to <a></a>+ } . f . canonicalizeTags . parseTagsOptions (parseOptionsEntities (const Nothing))++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"++balance :: [Text] -- ^ unclosed tags+ -> [Tag Text] -> [Tag Text]+balance unclosed [] = map TagClose $ filter (`notMember` voidElems) unclosed+balance (x:xs) tags'@(TagClose name:tags)+ | x == name = TagClose name : balance xs tags+ | 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+balance unclosed (t:ts) = t : balance unclosed ts++-- | Filters out unsafe tags and sanitizes attributes. Use with+-- filterTags to create a custom filter.+safeTags :: [Tag Text] -> [Tag Text]+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++-- | Directly removes tags even if they are not closed properly.+-- This is importent to clear out both the script and iframe tag +-- in sequences like "<script><iframe></iframe>".+clearTags :: [Tag Text] -> [Tag Text]+clearTags = clearTagsCustom clearableTagName++-- | Directly removes tags, like clearTags, but uses a custom+-- function for determining which tags are safe.+--+-- @clearTagsCustom clearableTagName@ is equivalent to+-- 'clearTags'.+clearTagsCustom :: (Text -> Bool) -> [Tag Text] -> [Tag Text]+clearTagsCustom _ [] = []+clearTagsCustom clearableName (tag@(TagOpen name _) : tags)+ | clearableName name = tag : go 0 tags+ | otherwise = tag : clearTagsCustom clearableName tags+ where+ go d (t@(TagOpen n _) : ts)+ | n /= name = go d ts+ | otherwise = go (d + 1) ts+ go d (t@(TagClose n) : ts)+ | n /= name = go d ts+ | d == 0 = t : clearTagsCustom clearableName ts+ | otherwise = go (d - 1) ts+ go d (t : ts) = go d ts+ go d [] = []+clearTagsCustom clearableName (t : tags) = t : clearTagsCustom clearableName tags++safeTagName :: Text -> Bool+safeTagName tagname = tagname `member` sanitaryTags++safeAttribute :: (Text, Text) -> Bool+safeAttribute (name, value) = name `member` sanitaryAttributes &&+ (name `notMember` uri_attributes || sanitaryURI value)++clearableTagName :: Text -> Bool+clearableTagName tagname = tagname `member` clearableTags++-- | 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+ ++-- | Returns @True@ if the specified URI is not a potential security risk.+sanitaryURI :: Text -> Bool+sanitaryURI u =+ case parseURIReference (escapeURI $ T.unpack u) of+ Just p -> (null (uriScheme p)) ||+ ((map toLower $ init $ uriScheme p) `member` safeURISchemes)+ Nothing -> False+++-- | Escape unicode characters in a URI. Characters that are+-- already valid in a URI, including % and ?, are left alone.+escapeURI :: String -> String+escapeURI = escapeURIString isAllowedInURI . encodeString++safeURISchemes :: Set String+safeURISchemes = fromList acceptable_protocols++sanitaryTags :: Set Text+sanitaryTags = fromList (acceptable_elements ++ mathml_elements ++ svg_elements)+ \\ (fromList svg_allow_local_href) -- extra filtering not implemented++sanitaryAttributes :: Set Text+sanitaryAttributes = fromList (allowed_html_uri_attributes ++ acceptable_attributes ++ mathml_attributes ++ svg_attributes)+ \\ (fromList svg_attr_val_allows_ref) -- extra unescaping not implemented++clearableTags :: Set Text+clearableTags = fromList ["script", "style"]++allowed_html_uri_attributes :: [Text]+allowed_html_uri_attributes = ["href", "src", "cite", "action", "longdesc"]++uri_attributes :: Set Text+uri_attributes = fromList $ allowed_html_uri_attributes ++ ["xlink:href", "xml:base"]++acceptable_elements :: [Text]+acceptable_elements = ["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",+ "dialog", "dir", "div", "dl", "dt", "em", "event-source", "fieldset",+ "figcaption", "figure", "footer", "font", "form", "header", "h1", "h2",+ "h3", "h4", "h5", "h6", "hr", "i", "img", "input", "ins", "keygen",+ "kbd", "label", "legend", "li", "m", "main", "map", "menu", "meter", "multicol",+ "nav", "nextid", "ol", "output", "optgroup", "option", "p", "pre",+ "progress", "q", "s", "samp", "section", "select", "small", "sound",+ "source", "spacer", "span", "strike", "strong", "sub", "sup", "table",+ "tbody", "td", "textarea", "time", "tfoot", "th", "thead", "tr", "tt",+ "u", "ul", "var", "video"]+ +mathml_elements :: [Text]+mathml_elements = ["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",+ "munderover", "none"]++-- this should include altGlyph I think+svg_elements :: [Text]+svg_elements = ["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",+ "mpath", "path", "polygon", "polyline", "radialGradient", "rect",+ "set", "stop", "svg", "switch", "text", "title", "tspan", "use"]+ +acceptable_attributes :: [Text]+acceptable_attributes = ["abbr", "accept", "accept-charset", "accesskey",+ "align", "alt", "autocomplete", "autofocus", "axis",+ "background", "balance", "bgcolor", "bgproperties", "border",+ "bordercolor", "bordercolordark", "bordercolorlight", "bottompadding",+ "cellpadding", "cellspacing", "ch", "challenge", "char", "charoff",+ "choff", "charset", "checked", "class", "clear", "color",+ "cols", "colspan", "compact", "contenteditable", "controls", "coords",+ -- "data", TODO: allow this with further filtering+ "datafld", "datapagesize", "datasrc", "datetime", "default",+ "delay", "dir", "disabled", "draggable", "dynsrc", "enctype", "end",+ "face", "for", "form", "frame", "galleryimg", "gutter", "headers",+ "height", "hidefocus", "hidden", "high", "hreflang", "hspace",+ "icon", "id", "inputmode", "ismap", "keytype", "label", "leftspacing",+ "lang", "list", "loop", "loopcount", "loopend",+ "loopstart", "low", "lowsrc", "max", "maxlength", "media", "method",+ "min", "multiple", "name", "nohref", "noshade", "nowrap", "open",+ "optimum", "pattern", "ping", "point-size", "prompt", "pqg",+ "radiogroup", "readonly", "rel", "repeat-max", "repeat-min",+ "replace", "required", "rev", "rightspacing", "rows", "rowspan",+ "rules", "scope", "selected", "shape", "size", "span", "start",+ "step",+ "style", -- gets further filtering+ "summary", "suppress", "tabindex", "target",+ "template", "title", "toppadding", "type", "unselectable", "usemap",+ "urn", "valign", "value", "variable", "volume", "vspace", "vrml",+ "width", "wrap", "xml:lang"]++acceptable_protocols :: [String]+acceptable_protocols = [ "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",+ "columnalign", "columnlines", "columnspacing", "columnspan", "depth",+ "display", "displaystyle", "equalcolumns", "equalrows", "fence",+ "fontstyle", "fontweight", "frame", "height", "linethickness", "lspace",+ "mathbackground", "mathcolor", "mathvariant", "mathvariant", "maxsize",+ "minsize", "other", "rowalign", "rowalign", "rowalign", "rowlines",+ "rowspacing", "rowspan", "rspace", "scriptlevel", "selection",+ "separator", "stretchy", "width", "width", "xlink:href", "xlink:show",+ "xlink:type", "xmlns", "xmlns:xlink"]++svg_attributes :: [Text]+svg_attributes = ["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",+ "cy", "d", "dx", "dy", "descent", "display", "dur", "end", "fill",+ "fill-opacity", "fill-rule", "font-family", "font-size",+ "font-stretch", "font-style", "font-variant", "font-weight", "from",+ "fx", "fy", "g1", "g2", "glyph-name", "gradientUnits", "hanging",+ "height", "horiz-adv-x", "horiz-origin-x", "id", "ideographic", "k",+ "keyPoints", "keySplines", "keyTimes", "lang", "marker-end",+ "marker-mid", "marker-start", "markerHeight", "markerUnits",+ "markerWidth", "mathematical", "max", "min", "name", "offset",+ "opacity", "orient", "origin", "overline-position",+ "overline-thickness", "panose-1", "path", "pathLength", "points",+ "preserveAspectRatio", "r", "refX", "refY", "repeatCount",+ "repeatDur", "requiredExtensions", "requiredFeatures", "restart",+ "rotate", "rx", "ry", "slope", "stemh", "stemv", "stop-color",+ "stop-opacity", "strikethrough-position", "strikethrough-thickness",+ "stroke", "stroke-dasharray", "stroke-dashoffset", "stroke-linecap",+ "stroke-linejoin", "stroke-miterlimit", "stroke-opacity",+ "stroke-width", "systemLanguage", "target", "text-anchor", "to",+ "transform", "type", "u1", "u2", "underline-position",+ "underline-thickness", "unicode", "unicode-range", "units-per-em",+ "values", "version", "viewBox", "visibility", "width", "widths", "x",+ "x-height", "x1", "x2", "xlink:actuate", "xlink:arcrole",+ "xlink:href", "xlink:role", "xlink:show", "xlink:title", "xlink:type",+ "xml:base", "xml:lang", "xml:space", "xmlns", "xmlns:xlink", "y",+ "y1", "y2", "zoomAndPan"]++-- 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",+ "filter", "marker", "marker-start", "marker-mid", "marker-end",+ "mask", "stroke"]++svg_allow_local_href :: [Text]+svg_allow_local_href = ["altGlyph", "animate", "animateColor",+ "animateMotion", "animateTransform", "cursor", "feImage", "filter",+ "linearGradient", "pattern", "radialGradient", "textpath", "tref",+ "set", "use"]
+ src/Text/HTML/SanitizeXSS/Css.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+module Text.HTML.SanitizeXSS.Css (+ sanitizeCSS+#ifdef TEST+, allowedCssAttributeValue+#endif+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Attoparsec.Text+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy (toStrict)+import Data.Set (member, fromList, Set)+import Data.Char (isDigit)+import Control.Applicative ((<|>), pure)+import Text.CSS.Render (renderAttrs)+import Text.CSS.Parse (parseAttrs)+import Prelude hiding (takeWhile)++-- import FileLocation (debug, debugM)+++-- this is a direct translation from sanitizer.py, except+-- sanitizer.py filters out url(), but this is redundant+sanitizeCSS :: Text -> Text+sanitizeCSS css = toStrict . toLazyText .+ renderAttrs . filter isSanitaryAttr . filterUrl $ parseAttributes+ where+ filterUrl :: [(Text,Text)] -> [(Text,Text)]+ filterUrl = map filterUrlAttribute+ where+ filterUrlAttribute :: (Text, Text) -> (Text, Text)+ filterUrlAttribute (prop,value) =+ case parseOnly rejectUrl value of+ Left _ -> (prop,value)+ Right noUrl -> filterUrlAttribute (prop, noUrl)++ rejectUrl = do+ pre <- manyTill anyChar (string "url")+ skipMany space+ _<-char '('+ skipWhile (/= ')')+ _<-char ')'+ rest <- takeText+ return $ T.append (T.pack pre) rest+++ parseAttributes = case parseAttrs css of+ Left _ -> []+ Right as -> as++ isSanitaryAttr (_, "") = False+ isSanitaryAttr ("",_) = False+ isSanitaryAttr (prop, value)+ | prop `member` allowed_css_properties = True+ | (T.takeWhile (/= '-') prop) `member` allowed_css_unit_properties &&+ all allowedCssAttributeValue (T.words value) = True+ | prop `member` allowed_svg_properties = True+ | otherwise = False++ allowed_css_unit_properties :: Set Text+ allowed_css_unit_properties = fromList ["background","border","margin","padding"]++allowedCssAttributeValue :: Text -> Bool+allowedCssAttributeValue val =+ val `member` allowed_css_keywords ||+ case parseOnly allowedCssAttributeParser val of+ Left _ -> False+ Right b -> b+ where+ allowedCssAttributeParser = do+ rgb <|> hex <|> rgb <|> cssUnit++ aToF = fromList "abcdef"++ hex = do+ _ <- char '#'+ hx <- takeText+ return $ T.all (\c -> isDigit c || (c `member` aToF)) hx++ -- should have used sepBy (symbol ",")+ rgb = do+ _<- string "rgb("+ skipMany1 digit >> skipOk (== '%')+ skip (== ',')+ skipMany digit >> skipOk (== '%')+ skip (== ',')+ skipMany digit >> skipOk (== '%')+ skip (== ')')+ return True++ cssUnit = do+ skip isDigit+ skipOk isDigit+ skipOk (== '.')+ skipOk isDigit >> skipOk isDigit+ skipSpace+ unit <- takeText+ return $ T.null unit || unit `member` allowed_css_attribute_value_units++skipOk :: (Char -> Bool) -> Parser ()+skipOk p = skip p <|> pure ()++allowed_css_attribute_value_units :: Set Text+allowed_css_attribute_value_units = fromList+ [ "cm", "em", "ex", "in", "mm", "pc", "pt", "px", "%", ",", "\\"]++allowed_css_properties :: Set Text+allowed_css_properties = fromList acceptable_css_properties+ where+ acceptable_css_properties = ["azimuth", "background-color",+ "border-bottom-color", "border-collapse", "border-color",+ "border-left-color", "border-right-color", "border-top-color", "clear",+ "color", "cursor", "direction", "display", "elevation", "float", "font",+ "font-family", "font-size", "font-style", "font-variant", "font-weight",+ "height", "letter-spacing", "line-height", "max-height", "max-width",+ "overflow", "pause", "pause-after", "pause-before", "pitch", "pitch-range",+ "richness", "speak", "speak-header", "speak-numeral", "speak-punctuation",+ "speech-rate", "stress", "text-align", "text-decoration", "text-indent",+ "unicode-bidi", "vertical-align", "voice-family", "volume",+ "white-space", "width"]++allowed_css_keywords :: Set Text+allowed_css_keywords = fromList acceptable_css_keywords+ where+ acceptable_css_keywords = ["auto", "aqua", "black", "block", "blue",+ "bold", "both", "bottom", "brown", "center", "collapse", "dashed",+ "dotted", "fuchsia", "gray", "green", "!important", "italic", "left",+ "lime", "maroon", "medium", "none", "navy", "normal", "nowrap", "olive",+ "pointer", "purple", "red", "right", "solid", "silver", "teal", "top",+ "transparent", "underline", "white", "yellow"]++-- used in css filtering+allowed_svg_properties :: Set Text+allowed_svg_properties = fromList acceptable_svg_properties+ where+ acceptable_svg_properties = [ "fill", "fill-opacity", "fill-rule",+ "stroke", "stroke-width", "stroke-linecap", "stroke-linejoin",+ "stroke-opacity"]
test/main.hs view
@@ -11,12 +11,25 @@ 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+ describe "Sanitized HTML is not changed" $ do+ it "HTML entities should not be escaped" $ do+ test (filterTags safeTags) "text more text" "text more text" describe "html sanitizing" $ do it "big test" $ do let testHTML = " <a href='http://safe.com'>safe</a><a href='unsafe://hack.com'>anchor</a> <img src='evil://evil.com' /> <unsafe></foo> <bar /> <br></br> <b>Unbalanced</div><img src='http://safe.com'>"@@ -85,3 +98,17 @@ sanitizedB "<img><hr/>" "<img><hr />" it "removes closing voids" $ 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>"
xss-sanitize.cabal view
@@ -1,59 +1,69 @@-name: xss-sanitize-version: 0.3.5.3-license: BSD3-license-file: LICENSE-author: Greg Weber <greg@gregweber.info>-maintainer: Greg Weber <greg@gregweber.info>-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-cabal-version: >= 1.8 -build-type: Simple-homepage: http://github.com/yesodweb/haskell-xss-sanitize-extra-source-files: README.md+cabal-version: 1.12 -flag network-uri- description: Get Network.URI from the network-uri package- default: True+-- This file has been generated from package.yaml by hpack version 0.35.1.+--+-- see: https://github.com/sol/hpack -library- build-depends: base == 4.*, containers- , tagsoup >= 0.12.2 && < 1- , utf8-string >= 0.3 && < 1- , css-text >= 0.1.1 && < 0.2- , text >= 0.11 && < 2- , attoparsec >= 0.10.0.3 && < 1+name: xss-sanitize+version: 0.3.7.2+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 - if flag(network-uri)- build-depends: network-uri >= 2.6- else- build-depends: network < 2.6+source-repository head+ type: git+ location: https://github.com/yesodweb/haskell-xss-sanitize - exposed-modules: Text.HTML.SanitizeXSS- other-modules: Text.HTML.SanitizeXSS.Css- ghc-options: -Wall+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.1+ , utf8-string >=0.3 && <1.1+ default-language: Haskell2010 test-suite test- type: exitcode-stdio-1.0- main-is: test/main.hs- cpp-options: -DTEST- build-depends: base == 4.* , containers- , tagsoup >= 0.12.2 && < 1- , utf8-string >= 0.3 && < 1- , css-text >= 0.1.1 && < 0.2- , text >= 0.11 && < 2- , attoparsec >= 0.10.0.3 && < 1- , hspec >= 1.3- , HUnit >= 1.2-- if flag(network-uri)- build-depends: network-uri >= 2.6- else- build-depends: network < 2.6---source-repository head- type: git - location: http://github.com/yesodweb/haskell-xss-sanitize.git+ 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.1+ , utf8-string >=0.3 && <1.1+ default-language: Haskell2010