{-# 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 = LazyText -> Text
toStrict (LazyText -> Text)
-> ([(Text, Text)] -> LazyText) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
toLazyText (Builder -> LazyText)
-> ([(Text, Text)] -> Builder) -> [(Text, Text)] -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[(Text, Text)] -> Builder
renderAttrs ([(Text, Text)] -> Builder)
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text, Text) -> Bool
isSanitaryAttr ([(Text, Text)] -> [(Text, Text)])
-> ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)]
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> [(Text, Text)]
filterUrl ([(Text, Text)] -> Text) -> [(Text, Text)] -> Text
forall a b. (a -> b) -> a -> b
$ [(Text, Text)]
parseAttributes
where
filterUrl :: [(Text,Text)] -> [(Text,Text)]
filterUrl :: [(Text, Text)] -> [(Text, Text)]
filterUrl = ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
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 Parser Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
parseOnly Parser 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
rejectUrl = do
pre <- Parser Text Char -> Parser Text -> Parser Text String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Text Char
anyChar (Text -> Parser Text
string Text
"url")
skipMany space
_<-char '('
skipWhile (/= ')')
_<-char ')'
rest <- takeText
return $ T.append (T.pack pre) 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 Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_properties = Bool
True
| ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
prop) Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_unit_properties Bool -> Bool -> Bool
&&
(Text -> Bool) -> [Text] -> 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 Text -> Set Text -> Bool
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 = [Text] -> Set Text
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 Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_keywords Bool -> Bool -> Bool
||
case Parser Bool -> Text -> Either String Bool
forall a. Parser a -> Text -> Either String a
parseOnly Parser Bool
allowedCssAttributeParser Text
val of
Left String
_ -> Bool
False
Right Bool
b -> Bool
b
where
allowedCssAttributeParser :: Parser Bool
allowedCssAttributeParser = do
Parser Bool
rgb Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Bool
hex Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Bool
rgb Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Bool
cssUnit
aToF :: Set Char
aToF = String -> Set Char
forall a. Ord a => [a] -> Set a
fromList String
"abcdef"
hex :: Parser Bool
hex = do
_ <- Char -> Parser Text Char
char Char
'#'
hx <- takeText
return $ T.all (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| (Char
c Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set Char
aToF)) hx
rgb :: Parser Bool
rgb = do
_<- Text -> Parser Text
string Text
"rgb("
skipMany1 digit >> skipOk (== '%')
skip (== ',')
skipMany digit >> skipOk (== '%')
skip (== ',')
skipMany digit >> skipOk (== '%')
skip (== ')')
return True
cssUnit :: Parser Bool
cssUnit = do
(Char -> Bool) -> Parser Text ()
skip Char -> Bool
isDigit
(Char -> Bool) -> Parser Text ()
skipOk Char -> Bool
isDigit
(Char -> Bool) -> Parser Text ()
skipOk (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
(Char -> Bool) -> Parser Text ()
skipOk Char -> Bool
isDigit Parser Text () -> Parser Text () -> Parser Text ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text ()
skipOk Char -> Bool
isDigit
Parser Text ()
skipSpace
unit <- Parser Text
takeText
return $ T.null unit || unit `member` allowed_css_attribute_value_units
skipOk :: (Char -> Bool) -> Parser ()
skipOk :: (Char -> Bool) -> Parser Text ()
skipOk Char -> Bool
p = (Char -> Bool) -> Parser Text ()
skip Char -> Bool
p Parser Text () -> Parser Text () -> Parser Text ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser Text ()
forall a. a -> Parser Text 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 = [Text] -> Set Text
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 = [Text] -> Set Text
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 = [Text] -> Set Text
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 = [Text] -> Set Text
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"]