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

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

-- 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"]