{-# LANGUAGE OverloadedStrings #-}
module Properties.Http (tests) where
import Test.QuickCheck
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Char (isControl)
import Data.IORef (newIORef, readIORef, writeIORef)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Network.HTTP.Types (Header, HeaderName, status200, status404)
import Network.Wai (Application, defaultRequest, responseLBS,
responseHeaders)
import Network.Wai.Internal (ResponseReceived(..))
import DarcsWeb.Http (securityHeaderList, securityHeaders, cspHeader,
mimeType, staticCacheControl, isValidRepoName,
sanitizeLogLine)
-- --------------------------------------------------------------------------
-- Behaviour 1: the security header list is exact. Every expected header
-- appears exactly once, nothing else is sent, and the application does
-- not emit HSTS (TLS terminates in Caddy, which owns that header).
-- --------------------------------------------------------------------------
expectedHeaders :: [Header]
expectedHeaders =
[ ("X-Content-Type-Options", "nosniff")
, ("X-Frame-Options", "DENY")
, ("Referrer-Policy", "strict-origin-when-cross-origin")
, ("Permissions-Policy", "camera=(), microphone=(), geolocation=(), payment=()")
, ("X-Robots-Tag", "noindex, nofollow")
, ("Cross-Origin-Opener-Policy", "same-origin")
, ("Cross-Origin-Resource-Policy", "same-origin")
, ("Content-Security-Policy", cspHeader)
]
countName :: HeaderName -> [Header] -> Int
countName n = length . filter ((== n) . fst)
-- Each expected header (name and value) is present exactly once.
prop_header_list_exact :: Bool
prop_header_list_exact =
all (\h@(n, _) -> countName n securityHeaderList == 1
&& h `elem` securityHeaderList) expectedHeaders
&& length securityHeaderList == length expectedHeaders
-- The app must not claim HSTS; it cannot know where TLS terminates.
prop_header_list_no_hsts :: Bool
prop_header_list_no_hsts =
countName "Strict-Transport-Security" securityHeaderList == 0
-- --------------------------------------------------------------------------
-- Behaviour 2: the CSP stays exactly as strict as before.
-- --------------------------------------------------------------------------
prop_csp_exact :: Bool
prop_csp_exact =
cspHeader == "default-src 'none'; style-src 'self'; img-src 'self'; \
\frame-ancestors 'none'; base-uri 'none'; form-action 'none'"
prop_csp_strict :: Bool
prop_csp_strict =
not (BS.isInfixOf "unsafe-inline" cspHeader)
&& not (BS.isInfixOf "unsafe-eval" cspHeader)
&& not (BS.isInfixOf "script-src" cspHeader)
&& not (BS.isInfixOf "font-src" cspHeader)
-- --------------------------------------------------------------------------
-- Behaviour 3: the middleware adds every header to every response,
-- regardless of status, and keeps the handler's own headers.
-- --------------------------------------------------------------------------
runMiddleware :: Application -> IO [Header]
runMiddleware inner = do
ref <- newIORef []
_ <- securityHeaders inner defaultRequest $ \resp -> do
writeIORef ref (responseHeaders resp)
return ResponseReceived
readIORef ref
stubApp :: Header -> Application
stubApp own _ respond =
respond (responseLBS status200 [own] (BL.fromStrict "ok"))
stub404 :: Application
stub404 _ respond = respond (responseLBS status404 [] "")
prop_middleware_adds_headers_200 :: Property
prop_middleware_adds_headers_200 = once $ ioProperty $ do
let own = ("Content-Type", "text/html; charset=utf-8")
hs <- runMiddleware (stubApp own)
return $ all (`elem` hs) expectedHeaders
&& own `elem` hs
&& all (\(n, _) -> countName n hs == 1) expectedHeaders
prop_middleware_adds_headers_404 :: Property
prop_middleware_adds_headers_404 = once $ ioProperty $ do
hs <- runMiddleware stub404
return $ all (`elem` hs) expectedHeaders
-- --------------------------------------------------------------------------
-- Behaviour 4: static MIME types and cache policy.
-- --------------------------------------------------------------------------
prop_mime_css :: Bool
prop_mime_css = mimeType ".css" == "text/css; charset=utf-8"
prop_mime_png :: Bool
prop_mime_png = mimeType ".png" == "image/png"
prop_mime_unknown :: Bool
prop_mime_unknown = and
[ mimeType "" == "application/octet-stream"
, mimeType ".exe" == "application/octet-stream"
, mimeType ".html" == "application/octet-stream"
, mimeType "css" == "application/octet-stream"
]
-- The stylesheet URL is unversioned, so it must be revalidatable after
-- a redesign ships: no 'immutable', but still cacheable.
prop_static_cache_not_immutable :: Bool
prop_static_cache_not_immutable =
not (TL.isInfixOf "immutable" staticCacheControl)
&& TL.isInfixOf "max-age=" staticCacheControl
-- --------------------------------------------------------------------------
-- Behaviour 5: repository name validation.
-- --------------------------------------------------------------------------
prop_repo_name_rejects :: Bool
prop_repo_name_rejects = not $ any isValidRepoName
[ "", ".", "..", ".x", "a/b", "a\\b", "a..b"
, "a\NULb", "a\nb", "a\tb", "a\rb", "\DEL", "a\x85" ]
prop_repo_name_accepts :: Bool
prop_repo_name_accepts = all isValidRepoName
[ "proj", "my-repo_1.0", "projekt-\228", "a b" ]
-- The guard that 'withRepo' used before this change. For every
-- non-empty name without control characters the new predicate must
-- agree with it exactly, so no previously reachable repo disappears and
-- no previously rejected name becomes reachable.
oldRepoGuardAccepts :: T.Text -> Bool
oldRepoGuardAccepts name =
not (T.any (== '/') name || T.any (== '\\') name
|| ".." `T.isInfixOf` name || T.isPrefixOf "." name)
prop_repo_name_matches_old_guard :: Property
prop_repo_name_matches_old_guard =
forAll nameGen $ \s ->
let t = T.pack s
in not (null s) && not (any isControl s) ==>
isValidRepoName t == oldRepoGuardAccepts t
where
nameGen = listOf (frequency [ (4, elements "./\\-_ a\228")
, (1, arbitrary) ])
prop_repo_name_rejects_control :: Property
prop_repo_name_rejects_control =
forAll (elements (filter isControl ['\0' .. '\x9f'])) $ \c ->
forAll (arbitrary :: Gen String) $ \s ->
not (isValidRepoName (T.pack ("r" ++ [c] ++ s)))
-- --------------------------------------------------------------------------
-- Behaviour 10: log lines are sanitised against log injection.
-- --------------------------------------------------------------------------
prop_sanitize_log_no_control :: Property
prop_sanitize_log_no_control =
forAll (listOf (frequency [ (3, elements "\n\r\t\NUL\ESC\DEL\x85")
, (2, arbitrary) ])) $ \s ->
not (any isControl (sanitizeLogLine s))
prop_sanitize_log_printable_unchanged :: Property
prop_sanitize_log_printable_unchanged =
forAll (listOf (arbitrary `suchThat` (not . isControl))) $ \s ->
sanitizeLogLine s == s
-- A multi-line exception message must collapse to a single log line.
prop_sanitize_log_single_line :: Bool
prop_sanitize_log_single_line =
let out = sanitizeLogLine "boom\nFAKE: admin logged in\r\n"
in notElem '\n' out && notElem '\r' out
&& "FAKE: admin logged in" `isSubOf` out
where
isSubOf needle hay = T.isInfixOf (T.pack needle) (T.pack hay)
-- --------------------------------------------------------------------------
-- Test runner
-- --------------------------------------------------------------------------
tests :: IO Bool
tests = fmap and $ sequence
[ run "1 header list exact" (property prop_header_list_exact)
, run "1 header list has no HSTS" (property prop_header_list_no_hsts)
, run "2 csp unchanged" (property prop_csp_exact)
, run "2 csp strict" (property prop_csp_strict)
, run "3 middleware headers on 200" prop_middleware_adds_headers_200
, run "3 middleware headers on 404" prop_middleware_adds_headers_404
, run "4 mime .css" (property prop_mime_css)
, run "4 mime .png" (property prop_mime_png)
, run "4 mime unknown → octet-stream" (property prop_mime_unknown)
, run "4 static cache not immutable" (property prop_static_cache_not_immutable)
, run "5 repo name rejects" (property prop_repo_name_rejects)
, run "5 repo name accepts" (property prop_repo_name_accepts)
, run "5 repo name matches old guard" prop_repo_name_matches_old_guard
, run "5 repo name rejects control" prop_repo_name_rejects_control
, run "10 sanitizeLogLine no control" prop_sanitize_log_no_control
, run "10 sanitizeLogLine printable id" prop_sanitize_log_printable_unchanged
, run "10 sanitizeLogLine single line" (property prop_sanitize_log_single_line)
]
where
run name prop = do
putStr $ " " ++ name ++ ": "
r <- quickCheckWithResult stdArgs { maxSuccess = 200 } prop
return (isSuccess r)
