106 lines
4.0 KiB
Haskell
106 lines
4.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Text.HTML.SanitizeXSS.Css (sanitizeCSS) 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 ((<|>))
|
|
import Text.CSS.Render (renderAttrs)
|
|
import Text.CSS.Parse (parseAttrs)
|
|
|
|
|
|
-- 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 $ parseAttributes
|
|
where
|
|
parseAttributes = case parseOnly parseAttrs css of
|
|
Left _ -> []
|
|
Right as -> as
|
|
|
|
isSanitaryAttr (prop, value)
|
|
| prop `member` allowed_css_properties = True
|
|
| (T.takeWhile (/= '-') value) `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
|
|
hex <|> rgb <|> cssUnit
|
|
|
|
aToF = fromList "abcdef"
|
|
|
|
hex = do
|
|
_ <- char '#'
|
|
hx <- takeText
|
|
return $ T.all (\c -> isDigit c || (c `member` aToF)) hx
|
|
|
|
rgb = do
|
|
_<- string "rgb("
|
|
skip isDigit >> try (skipWhile isDigit) >> try (skip (== '%'))
|
|
skip (== ',')
|
|
try (skipWhile isDigit) >> try (skip (== '%'))
|
|
skip (== ',')
|
|
try (skipWhile isDigit) >> try (skip (== '%'))
|
|
skip (== ',')
|
|
skip (== ')')
|
|
return True
|
|
|
|
cssUnit = do
|
|
try $ skip isDigit >> skip isDigit
|
|
try $ skip (== '.')
|
|
try $ skip isDigit >> skip isDigit
|
|
unit <- takeText
|
|
return $ unit `member` allowed_css_attribute_value_units
|
|
|
|
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"]
|