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

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

-- 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 = [ "fill", "fill-opacity", "fill-rule",
        "stroke", "stroke-width", "stroke-linecap", "stroke-linejoin",
        "stroke-opacity"]