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