{-# 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)
sanitizeCSS :: Text -> Text
sanitizeCSS :: Text -> Text
sanitizeCSS Text
css = Text -> Text
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[(Text, Text)] -> Builder
renderAttrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Text, Text) -> Bool
isSanitaryAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> [(Text, Text)]
filterUrl forall a b. (a -> b) -> a -> b
$ [(Text, Text)]
parseAttributes
where
filterUrl :: [(Text,Text)] -> [(Text,Text)]
filterUrl :: [(Text, Text)] -> [(Text, Text)]
filterUrl = forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (Text, Text)
filterUrlAttribute
where
filterUrlAttribute :: (Text, Text) -> (Text, Text)
filterUrlAttribute :: (Text, Text) -> (Text, Text)
filterUrlAttribute (Text
prop,Text
value) =
case forall a. Parser a -> Text -> Either String a
parseOnly Parser Text Text
rejectUrl Text
value of
Left String
_ -> (Text
prop,Text
value)
Right Text
noUrl -> (Text, Text) -> (Text, Text)
filterUrlAttribute (Text
prop, Text
noUrl)
rejectUrl :: Parser Text Text
rejectUrl = do
String
pre <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (Text -> Parser Text Text
string Text
"url")
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser Char
space
Char
_<-Char -> Parser Char
char Char
'('
(Char -> Bool) -> Parser ()
skipWhile (forall a. Eq a => a -> a -> Bool
/= Char
')')
Char
_<-Char -> Parser Char
char Char
')'
Text
rest <- Parser Text Text
takeText
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append (String -> Text
T.pack String
pre) Text
rest
parseAttributes :: [(Text, Text)]
parseAttributes = case Text -> Either String [(Text, Text)]
parseAttrs Text
css of
Left String
_ -> []
Right [(Text, Text)]
as -> [(Text, Text)]
as
isSanitaryAttr :: (Text, Text) -> Bool
isSanitaryAttr (Text
_, Text
"") = Bool
False
isSanitaryAttr (Text
"",Text
_) = Bool
False
isSanitaryAttr (Text
prop, Text
value)
| Text
prop forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_properties = Bool
True
| ((Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
prop) forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_unit_properties Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
allowedCssAttributeValue (Text -> [Text]
T.words Text
value) = Bool
True
| Text
prop forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_svg_properties = Bool
True
| Bool
otherwise = Bool
False
allowed_css_unit_properties :: Set Text
allowed_css_unit_properties :: Set Text
allowed_css_unit_properties = forall a. Ord a => [a] -> Set a
fromList [Text
"background",Text
"border",Text
"margin",Text
"padding"]
allowedCssAttributeValue :: Text -> Bool
allowedCssAttributeValue :: Text -> Bool
allowedCssAttributeValue Text
val =
Text
val forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_keywords Bool -> Bool -> Bool
||
case forall a. Parser a -> Text -> Either String a
parseOnly Parser Text Bool
allowedCssAttributeParser Text
val of
Left String
_ -> Bool
False
Right Bool
b -> Bool
b
where
allowedCssAttributeParser :: Parser Text Bool
allowedCssAttributeParser = do
Parser Text Bool
rgb forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Bool
hex forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Bool
rgb forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Bool
cssUnit
aToF :: Set Char
aToF = forall a. Ord a => [a] -> Set a
fromList String
"abcdef"
hex :: Parser Text Bool
hex = do
Char
_ <- Char -> Parser Char
char Char
'#'
Text
hx <- Parser Text Text
takeText
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| (Char
c forall a. Ord a => a -> Set a -> Bool
`member` Set Char
aToF)) Text
hx
rgb :: Parser Text Bool
rgb = do
Text
_<- Text -> Parser Text Text
string Text
"rgb("
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany1 Parser Char
digit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
skipOk (forall a. Eq a => a -> a -> Bool
== Char
'%')
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
',')
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser Char
digit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
skipOk (forall a. Eq a => a -> a -> Bool
== Char
'%')
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
',')
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser Char
digit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
skipOk (forall a. Eq a => a -> a -> Bool
== Char
'%')
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
')')
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
cssUnit :: Parser Text Bool
cssUnit = do
(Char -> Bool) -> Parser ()
skip Char -> Bool
isDigit
(Char -> Bool) -> Parser ()
skipOk Char -> Bool
isDigit
(Char -> Bool) -> Parser ()
skipOk (forall a. Eq a => a -> a -> Bool
== Char
'.')
(Char -> Bool) -> Parser ()
skipOk Char -> Bool
isDigit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
skipOk Char -> Bool
isDigit
Parser ()
skipSpace
Text
unit <- Parser Text Text
takeText
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
unit Bool -> Bool -> Bool
|| Text
unit forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_attribute_value_units
skipOk :: (Char -> Bool) -> Parser ()
skipOk :: (Char -> Bool) -> Parser ()
skipOk Char -> Bool
p = (Char -> Bool) -> Parser ()
skip Char -> Bool
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
allowed_css_attribute_value_units :: Set Text
allowed_css_attribute_value_units :: Set Text
allowed_css_attribute_value_units = forall a. Ord a => [a] -> Set a
fromList
[ Text
"cm", Text
"em", Text
"ex", Text
"in", Text
"mm", Text
"pc", Text
"pt", Text
"px", Text
"%", Text
",", Text
"\\"]
allowed_css_properties :: Set Text
allowed_css_properties :: Set Text
allowed_css_properties = forall a. Ord a => [a] -> Set a
fromList [Text]
acceptable_css_properties
where
acceptable_css_properties :: [Text]
acceptable_css_properties = [Text
"azimuth", Text
"background-color",
Text
"border-bottom-color", Text
"border-collapse", Text
"border-color",
Text
"border-left-color", Text
"border-right-color", Text
"border-top-color", Text
"clear",
Text
"color", Text
"cursor", Text
"direction", Text
"display", Text
"elevation", Text
"float", Text
"font",
Text
"font-family", Text
"font-size", Text
"font-style", Text
"font-variant", Text
"font-weight",
Text
"height", Text
"letter-spacing", Text
"line-height", Text
"max-height", Text
"max-width",
Text
"overflow", Text
"pause", Text
"pause-after", Text
"pause-before", Text
"pitch", Text
"pitch-range",
Text
"richness", Text
"speak", Text
"speak-header", Text
"speak-numeral", Text
"speak-punctuation",
Text
"speech-rate", Text
"stress", Text
"text-align", Text
"text-decoration", Text
"text-indent",
Text
"unicode-bidi", Text
"vertical-align", Text
"voice-family", Text
"volume",
Text
"white-space", Text
"width"]
allowed_css_keywords :: Set Text
allowed_css_keywords :: Set Text
allowed_css_keywords = forall a. Ord a => [a] -> Set a
fromList [Text]
acceptable_css_keywords
where
acceptable_css_keywords :: [Text]
acceptable_css_keywords = [Text
"auto", Text
"aqua", Text
"black", Text
"block", Text
"blue",
Text
"bold", Text
"both", Text
"bottom", Text
"brown", Text
"center", Text
"collapse", Text
"dashed",
Text
"dotted", Text
"fuchsia", Text
"gray", Text
"green", Text
"!important", Text
"italic", Text
"left",
Text
"lime", Text
"maroon", Text
"medium", Text
"none", Text
"navy", Text
"normal", Text
"nowrap", Text
"olive",
Text
"pointer", Text
"purple", Text
"red", Text
"right", Text
"solid", Text
"silver", Text
"teal", Text
"top",
Text
"transparent", Text
"underline", Text
"white", Text
"yellow"]
allowed_svg_properties :: Set Text
allowed_svg_properties :: Set Text
allowed_svg_properties = forall a. Ord a => [a] -> Set a
fromList [Text]
acceptable_svg_properties
where
acceptable_svg_properties :: [Text]
acceptable_svg_properties = [ Text
"fill", Text
"fill-opacity", Text
"fill-rule",
Text
"stroke", Text
"stroke-width", Text
"stroke-linecap", Text
"stroke-linejoin",
Text
"stroke-opacity"]