Merge PR #990

wai-extra/ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for wai-extra
 
+## 3.1.15
+
+* Added `validateHeadersMiddleware` for validating response headers set by the application [#990](https://github.com/yesodweb/wai/pull/990).
+
 ## 3.1.14
 
 * Request parsing throws an exception rather than `error`ing [#972](https://github.com/yesodweb/wai/pull/972):

wai-extra/Network/Wai/Middleware/ValidateHeaders.hs

@@ -0,0 +1,138 @@
+-- | This module provides a middleware to validate response headers.
+-- [RFC 9110](https://www.rfc-editor.org/rfc/rfc9110.html#section-5) constrains the allowed octets in header names and values:
+--
+-- * Header names are [tokens](https://www.rfc-editor.org/rfc/rfc9110#section-5.6.2), i.e. visible ASCII characters (octets 33 to 126 inclusive) except delimiters.
+-- * Header values should be limited to visible ASCII characters, the whitespace characters space and horizontal tab and octets 128 to 255. Headers values may not have trailing whitespace (see [RFC 9110 Section 5.5](https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5)). Folding is not allowed.
+--
+-- 'validateHeadersMiddleware' enforces these constraints for response headers by responding with a 500 Internal Server Error when an offending character is present. This is meant to catch programmer errors early on and reduce attack surface.
+module Network.Wai.Middleware.ValidateHeaders
+    -- * Middleware
+    ( validateHeadersMiddleware
+    -- * Settings
+    , ValidateHeadersSettings (..)
+    , defaultValidateHeadersSettings
+    -- * Types
+    , InvalidHeader (..)
+    , InvalidHeaderReason (..)
+    ) where
+
+import Data.CaseInsensitive (original)
+import Data.Char (chr)
+import Data.Word (Word8)
+import Network.HTTP.Types (Header, ResponseHeaders, internalServerError500)
+import Network.Wai (Middleware, Response, responseHeaders, responseLBS)
+import Text.Printf (printf)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BSL
+
+-- | Middleware to validate response headers.
+--
+-- @since 3.1.15
+validateHeadersMiddleware :: ValidateHeadersSettings -> Middleware
+validateHeadersMiddleware settings app req respond =
+    app req respond'
+    where
+        respond' response = case getInvalidHeader $ responseHeaders response of
+            Just invalidHeader -> onInvalidHeader settings invalidHeader app req respond
+            Nothing -> respond response
+
+-- | Configuration for 'validateHeadersMiddleware'.
+-- 
+-- @since 3.1.15
+data ValidateHeadersSettings = ValidateHeadersSettings
+  -- | Called when an invalid header is present.
+  { onInvalidHeader :: InvalidHeader -> Middleware
+  }
+
+-- | Default configuration for 'validateHeadersMiddleware'.
+-- Checks that each header meets the requirements listed at the top of this module: Allowed octets for name and value and no trailing whitespace in the value.
+--
+-- @since 3.1.15
+defaultValidateHeadersSettings :: ValidateHeadersSettings
+defaultValidateHeadersSettings = ValidateHeadersSettings
+  { onInvalidHeader = \invalidHeader _app _req respond -> respond $ invalidHeaderResponse invalidHeader
+  }
+
+-- | Description of an invalid header.
+--
+-- @since 3.1.15
+data InvalidHeader = InvalidHeader Header InvalidHeaderReason
+
+-- | Reasons a header might be invalid.
+--
+-- @since 3.1.15
+data InvalidHeaderReason
+  -- | Header name contains an invalid octet.
+  = InvalidOctetInHeaderName Word8
+  -- | Header value contains an invalid octet.
+  | InvalidOctetInHeaderValue Word8
+  -- | Header value contains trailing whitespace.
+  | TrailingWhitespaceInHeaderValue
+
+-- Internal stuff.
+-- 'getInvalidHeader' returns an appropriate 'InvalidHeader' for a given header if applicable.
+-- 'invalidHeaderResponse' creates a 'Response' for a given 'InvalidHeader'.
+
+getInvalidHeader :: ResponseHeaders -> Maybe InvalidHeader
+getInvalidHeader = firstJust . map go
+    where
+        firstJust :: [Maybe a] -> Maybe a
+        firstJust [] = Nothing
+        firstJust (Just x : _) = Just x
+        firstJust (_ : xs) = firstJust xs
+
+        go :: Header -> Maybe InvalidHeader
+        go header@(name, value) = InvalidHeader header <$> firstJust
+          [ InvalidOctetInHeaderName <$> BS.find (not . isValidHeaderNameOctet) (original name)
+          , InvalidOctetInHeaderValue <$> BS.find (not . isValidHeaderValueOctet) value
+          , if hasTrailingWhitespace value then Just TrailingWhitespaceInHeaderValue else Nothing
+          ]
+
+isValidHeaderNameOctet :: Word8 -> Bool
+isValidHeaderNameOctet octet =
+    isVisibleASCII octet && not (isDelimiter octet)
+
+isValidHeaderValueOctet :: Word8 -> Bool
+isValidHeaderValueOctet octet =
+    isVisibleASCII octet || isWhitespace octet || isObsText octet
+
+isVisibleASCII :: Word8 -> Bool
+isVisibleASCII octet = octet >= 33 && octet <= 126
+
+isDelimiter :: Word8 -> Bool
+isDelimiter octet = chr (fromIntegral octet) `elem` ("\"(),/:;<=>?@[\\]{}" :: String)
+
+-- Whitespace characters are only horizontal tab and space here.
+isWhitespace :: Word8 -> Bool
+isWhitespace octet = octet == 0x9 || octet == 0x20
+
+isObsText :: Word8 -> Bool
+isObsText octet = octet >= 0x80
+
+hasTrailingWhitespace :: BS.ByteString -> Bool
+hasTrailingWhitespace bs
+  | BS.length bs == 0 = False
+  | otherwise = isWhitespace (BS.index bs 0) || isWhitespace (BS.index bs $ BS.length bs - 1)
+
+invalidHeaderResponse :: InvalidHeader -> Response
+invalidHeaderResponse (InvalidHeader (headerName, headerValue) reason) =
+    responseLBS internalServerError500 [("Content-Type", "text/plain")] $ BSL.concat
+        [ "Invalid response header found:\n"
+        , "In header '"
+        , BSL.fromStrict $ original headerName
+        , "' with value '"
+        , BSL.fromStrict $ headerValue
+        , "': "
+        , showReason reason
+        , "\nYou are seeing this error message because validateHeadersMiddleware is enabled."
+        ]
+    where
+        showReason (InvalidOctetInHeaderName octet) = "Name contains invalid octet " <> showOctet octet
+        showReason (InvalidOctetInHeaderValue octet) = "Value contains invalid octet " <> showOctet octet
+        showReason TrailingWhitespaceInHeaderValue = "Value contains trailing whitespace."
+
+        showOctet octet
+            | isVisibleASCII octet = BSL.fromStrict $ BS8.pack $ printf "'%c' (0x%02X)" (chr $ fromIntegral octet) octet
+            | otherwise = BSL.fromStrict $ BS8.pack $ printf "0x%02X" octet

wai-extra/test/Network/Wai/Middleware/ValidateHeadersSpec.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Wai.Middleware.ValidateHeadersSpec (spec) where
+
+import Network.HTTP.Types (ResponseHeaders, status200)
+import Network.Wai (Application, defaultRequest, responseLBS)
+import Test.Hspec (Spec, describe, it)
+
+import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings)
+import Network.Wai.Test (Session, assertStatus, request, withSession)
+
+spec :: Spec
+spec = do
+    describe "validateHeadersMiddleware" $ do
+        it "allows token characters in header names" $ withHeadersApp [("token!#$%&'*+-.^_`|~123", "bar")] $ do
+            assertStatus 200 =<< request defaultRequest
+
+        it "does not allow colons in header names" $ withHeadersApp [("broken:header", "foo")] $ do
+            assertStatus 500 =<< request defaultRequest
+
+        it "does not allow whitespace in header names" $ do
+            withHeadersApp [("white space", "foo")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("white\nspace", "foo")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("white\rspace", "foo")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("white\tspace", "foo")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("ehite\vspace", "foo")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("white\fspace", "foo")] $ assertStatus 500 =<< request defaultRequest
+
+        it "allows visible ASCII, space and horizontal tab in header values" $ do
+            withHeadersApp [("MyHeader", "the quick brown\tfox jumped over the lazy dog!")] $ do
+                assertStatus 200 =<< request defaultRequest
+
+        it "allows octets beyond 0x80 in headers values" $ do
+            -- Just an example
+            withHeadersApp [("MyHeader", "verr\252ckt")] $ do
+                assertStatus 200 =<< request defaultRequest
+
+        it "does not allow other whitespace in header values" $ do
+            withHeadersApp [("MyHeader", "white\nspace")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("MyHeader", "white\rspace")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("MyHeader", "white\vspace")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("MyHeader", "white\fspace")] $ assertStatus 500 =<< request defaultRequest
+
+        it "does not allow control characters in header values" $ do
+            -- Just examples again
+            withHeadersApp [("MyHeader", "control character \0")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("MyHeader", "control character \27")] $ assertStatus 500 =<< request defaultRequest
+
+        it "does not allow trailing whitespace in header values" $ do
+            withHeadersApp [("MyHeader", " foo")] $ assertStatus 500 =<< request defaultRequest
+            withHeadersApp [("MyHeader", "foo ")] $ assertStatus 500 =<< request defaultRequest
+
+withHeadersApp :: ResponseHeaders -> Session a -> IO a
+withHeadersApp headers session =
+  withSession (validateHeadersMiddleware defaultValidateHeadersSettings $ headersApp headers) session
+
+headersApp :: ResponseHeaders -> Application
+headersApp headers _ respond =
+  respond $ responseLBS status200 headers ""

wai-extra/wai-extra.cabal

@@ -1,5 +1,5 @@
 Name:                wai-extra
-Version:             3.1.14
+Version:             3.1.15
 Synopsis:            Provides some basic WAI handlers and middleware.
 description:
   Provides basic WAI handler and middleware functionality:
@@ -166,6 +166,7 @@ Library
                      Network.Wai.Middleware.StreamFile
                      Network.Wai.Middleware.StripHeaders
                      Network.Wai.Middleware.Timeout
+                     Network.Wai.Middleware.ValidateHeaders
                      Network.Wai.Middleware.Vhost
                      Network.Wai.Parse
                      Network.Wai.Request
@@ -206,6 +207,7 @@ test-suite spec
                      Network.Wai.Middleware.SelectSpec
                      Network.Wai.Middleware.StripHeadersSpec
                      Network.Wai.Middleware.TimeoutSpec
+                     Network.Wai.Middleware.ValidateHeadersSpec
                      Network.Wai.ParseSpec
                      Network.Wai.RequestSpec
                      Network.Wai.TestSpec