{-# 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 :: Text -> Text
sanitizeCSS 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 (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
          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 Text
"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
'('
          (Char -> Bool) -> Parser Text ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')')
          Char
_<-Char -> Parser Text Char
char Char
')'
          Text
rest <- Parser Text
takeText
          Text -> Parser Text
forall a. a -> Parser Text a
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 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
_ <- Char -> Parser Text Char
char Char
'#'
      Text
hx <- Parser Text
takeText
      Bool -> Parser Bool
forall a. a -> Parser Text a
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 (\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

    -- should have used sepBy (symbol ",")
    rgb :: Parser Bool
rgb = do
      Text
_<- Text -> Parser Text
string Text
"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 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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
      (Char -> Bool) -> Parser Text ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')
      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 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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
      (Char -> Bool) -> Parser Text ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')
      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 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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
      (Char -> Bool) -> Parser Text ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
      Bool -> Parser Bool
forall a. a -> Parser Text a
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
'.')
      (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
      Text
unit <- Parser Text
takeText
      Bool -> Parser Bool
forall a. a -> Parser Text a
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 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"]

-- used in css filtering
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"]