{-# 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 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

    -- should have used sepBy (symbol ",")
    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"]

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