darcsweb - test/Properties/Csp.hs

{-# LANGUAGE OverloadedStrings #-}

module Properties.Csp (tests) where

import Test.QuickCheck
import qualified CspPure

-- --------------------------------------------------------------------------
-- sanitize_value properties
-- --------------------------------------------------------------------------

prop_sanitize_no_semicolons :: String -> Bool
prop_sanitize_no_semicolons s =
    ';' `notElem` CspPure.sanitize_value s

prop_sanitize_empty :: Bool
prop_sanitize_empty = CspPure.sanitize_value "" == ""

prop_sanitize_preserves_safe :: String -> Property
prop_sanitize_preserves_safe s =
    all (/= ';') s ==>
    CspPure.sanitize_value s == s

-- --------------------------------------------------------------------------
-- build_directive properties
-- --------------------------------------------------------------------------

prop_directive_starts_with_name :: String -> String -> Property
prop_directive_starts_with_name name value =
    not (null name) ==>
    let result = CspPure.build_directive name value
    in take (length name) result == name

prop_directive_has_space :: String -> String -> Property
prop_directive_has_space name value =
    not (null name) ==>
    let result = CspPure.build_directive name value
    in result !! length name == ' '

-- --------------------------------------------------------------------------
-- build_csp properties
-- --------------------------------------------------------------------------

prop_csp_empty :: Bool
prop_csp_empty = CspPure.build_csp [] == ""

prop_csp_single :: Bool
prop_csp_single =
    CspPure.build_csp [("default-src", "'none'")] ==
    "default-src 'none'"

-- | Directive names are programmer-controlled (no semicolons).
--   Values are arbitrary (may contain semicolons from user input).
--   The builder must ensure no semicolons leak into values.
prop_csp_no_value_semicolons :: Property
prop_csp_no_value_semicolons =
    forAll genDirectives $ \directives ->
    let result = CspPure.build_csp directives
        parts = splitOnSemiSpace result
    in all (notElem ';') parts
  where
    genDirectives = do
      n <- choose (1, 5)
      vectorOf n genDirective
    genDirective = do
      name <- elements ["default-src", "style-src", "img-src", "script-src",
                         "frame-ancestors", "base-uri", "form-action"]
      value <- arbitrary
      return (name, value)
    splitOnSemiSpace [] = [""]
    splitOnSemiSpace (';':' ':rest) = "" : splitOnSemiSpace rest
    splitOnSemiSpace (c:rest) = case splitOnSemiSpace rest of
      (h:t) -> (c:h):t
      []    -> [[c]]

-- --------------------------------------------------------------------------
-- Test runner
-- --------------------------------------------------------------------------

tests :: IO Bool
tests = fmap and $ sequence
    [ run "sanitize: no semicolons"        (property prop_sanitize_no_semicolons)
    , run "sanitize: empty"                (property prop_sanitize_empty)
    , run "sanitize: preserves safe"       prop_sanitize_preserves_safe
    , run "directive: starts with name"    prop_directive_starts_with_name
    , run "directive: has space separator"  prop_directive_has_space
    , run "csp: empty list"                (property prop_csp_empty)
    , run "csp: single directive"          (property prop_csp_single)
    , run "csp: no value semicolons"       prop_csp_no_value_semicolons
    ]
  where
    run name prop = do
      putStr $ "  " ++ name ++ ": "
      r <- quickCheckWithResult stdArgs { maxSuccess = 200 } prop
      return (isSuccess r)