darcsweb - src/DarcsWeb/Http.hs

{-# LANGUAGE OverloadedStrings #-}

-- | HTTP-level pieces shared by the executable and the test suite:
--   response security headers, the verified CSP, static MIME types,
--   repository-name validation and log-line sanitising. Kept in the
--   library (not in @app/Main.hs@) so the test suite can reach them.
module DarcsWeb.Http
  ( securityHeaderList
  , securityHeaders
  , cspHeader
  , mimeType
  , staticCacheControl
  , isValidRepoName
  , sanitizeLogLine
  ) where

import qualified Data.ByteString.Char8 as BC
import           Data.Char (isControl)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import           Network.HTTP.Types (Header)
import           Network.Wai (Middleware, modifyResponse, mapResponseHeaders)

import qualified CspPure

-- | Map file extension to MIME type for static assets
mimeType :: String -> TL.Text
mimeType ".css"  = "text/css; charset=utf-8"
mimeType ".js"   = "application/javascript"
mimeType ".png"  = "image/png"
mimeType ".jpg"  = "image/jpeg"
mimeType ".jpeg" = "image/jpeg"
mimeType ".gif"  = "image/gif"
mimeType ".svg"  = "image/svg+xml"
mimeType ".ico"  = "image/x-icon"
mimeType ".woff" = "font/woff"
mimeType ".woff2" = "font/woff2"
mimeType _       = "application/octet-stream"

-- | Cache policy for static assets. Not @immutable@: the stylesheet URL
--   is unversioned, so browsers must be able to revalidate after a
--   redesign ships.
staticCacheControl :: TL.Text
staticCacheControl = "public, max-age=3600"

-- | Build CSP header using formally verified builder from Rocq.
--   The builder guarantees no semicolon injection within directive values.
cspHeader :: BC.ByteString
cspHeader = BC.pack $ CspPure.build_csp
    [ ("default-src", "'none'")
    , ("style-src",   "'self'")
    , ("img-src",     "'self'")
    , ("frame-ancestors", "'none'")
    , ("base-uri",    "'none'")
    , ("form-action", "'none'")
    ]

-- | Security headers added to every response. HSTS is deliberately left
--   to the TLS-terminating proxy, which knows whether TLS is in use.
securityHeaderList :: [Header]
securityHeaderList =
    [ ("X-Content-Type-Options", "nosniff")
    , ("X-Frame-Options", "DENY")
    , ("Referrer-Policy", "strict-origin-when-cross-origin")
    , ("Permissions-Policy", "camera=(), microphone=(), geolocation=(), payment=()")
    , ("Content-Security-Policy", cspHeader)
    , ("X-Robots-Tag", "noindex, nofollow")
    , ("Cross-Origin-Opener-Policy", "same-origin")
    , ("Cross-Origin-Resource-Policy", "same-origin")
    ]

-- | WAI middleware that adds security response headers to every response.
securityHeaders :: Middleware
securityHeaders = modifyResponse $ mapResponseHeaders (++ securityHeaderList)

-- | Repository names must be a single, non-hidden path component without
--   control characters (NUL would be truncated by C path APIs).
isValidRepoName :: T.Text -> Bool
isValidRepoName name =
    not (T.null name
         || T.any isControl name
         || T.any (== '/') name || T.any (== '\\') name
         || ".." `T.isInfixOf` name
         || T.isPrefixOf "." name)

-- | Replace control characters so request-derived text cannot forge or
--   split log lines.
sanitizeLogLine :: String -> String
sanitizeLogLine = map (\c -> if isControl c then ' ' else c)