{-# 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 css :: Text
css = Text -> Text
toStrict (Text -> Text)
-> ([(Text, Text)] -> Text) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text)
-> ([(Text, Text)] -> Builder) -> [(Text, Text)] -> Text
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 (prop :: Text
prop,value :: 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 _ -> (Text
prop,Text
value)
Right noUrl :: Text
noUrl -> (Text, Text) -> (Text, Text)
filterUrlAttribute (Text
prop, Text
noUrl)
rejectUrl :: Parser Text
rejectUrl = do
String
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 "url")
Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser Text Char
space
Char
_<-Char -> Parser Text Char
char '('
(Char -> Bool) -> Parser Text ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ')')
Char
_<-Char -> Parser Text Char
char ')'
Text
rest <- Parser Text
takeText
Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
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 _ -> []
Right as :: [(Text, Text)]
as -> [(Text, Text)]
as
isSanitaryAttr :: (Text, Text) -> Bool
isSanitaryAttr (_, "") = Bool
False
isSanitaryAttr ("",_) = Bool
False
isSanitaryAttr (prop :: Text
prop, value :: 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
/= '-') 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 ["background","border","margin","padding"]
allowedCssAttributeValue :: Text -> Bool
allowedCssAttributeValue :: Text -> Bool
allowedCssAttributeValue val :: 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 _ -> Bool
False
Right b :: Bool
b -> Bool
b
where
allowedCssAttributeParser :: Parser Bool
allowedCssAttributeParser = do
Parser Bool
rgb Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Bool
hex Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Bool
rgb Parser Bool -> Parser Bool -> Parser Bool
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 "abcdef"
hex :: Parser Bool
hex = do
Char
_ <- Char -> Parser Text Char
char '#'
Text
hx <- Parser Text
takeText
Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Parser Bool) -> Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Bool
T.all (\c :: 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)) Text
hx
rgb :: Parser Bool
rgb = do
Text
_<- Text -> Parser Text
string "rgb("
Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany1 Parser Text Char
digit Parser Text () -> Parser Text () -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text ()
skipOk (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '%')
(Char -> Bool) -> Parser Text ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ',')
Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser Text Char
digit Parser Text () -> Parser Text () -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text ()
skipOk (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '%')
(Char -> Bool) -> Parser Text ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ',')
Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany Parser Text Char
digit Parser Text () -> Parser Text () -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text ()
skipOk (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '%')
(Char -> Bool) -> Parser Text ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')')
Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 -> Bool) -> Parser Text ()
skipOk Char -> Bool
isDigit Parser Text () -> Parser Text () -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text ()
skipOk Char -> Bool
isDigit
Parser Text ()
skipSpace
Text
unit <- Parser Text
takeText
Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Parser Bool) -> Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
unit Bool -> Bool -> Bool
|| Text
unit Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set Text
allowed_css_attribute_value_units
skipOk :: (Char -> Bool) -> Parser ()
skipOk :: (Char -> Bool) -> Parser Text ()
skipOk p :: Char -> Bool
p = (Char -> Bool) -> Parser Text ()
skip Char -> Bool
p Parser Text () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser Text ()
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
[ "cm", "em", "ex", "in", "mm", "pc", "pt", "px", "%", ",", "\\"]
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 = ["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 :: 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 = ["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"]
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 = [ "fill", "fill-opacity", "fill-rule",
"stroke", "stroke-width", "stroke-linecap", "stroke-linejoin",
"stroke-opacity"]