diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,12 +2,13 @@ ## 3.1.15 -* Request parsing throws an exception rather than `error`ing [#964](https://github.com/yesodweb/wai/pull/964): - * Add `RequestParseException` type and expose it from the `Network.Wai.Parse` module. - * Behavior change : `parseRequestBody` and `parseRequestBodyEx` (exported from `Network.Wai.Parse`) throw `RequestParseException` rather than calling `error`. +* Added `validateHeadersMiddleware` for validating response headers set by the application [#990](https://github.com/yesodweb/wai/pull/990). -## 3.1.14.0 +## 3.1.14 +* Request parsing throws an exception rather than `error`ing [#972](https://github.com/yesodweb/wai/pull/972): + * Add `RequestParseException` type and expose it from the `Network.Wai.Parse` module. + * Behavior change : `parseRequestBody` and `parseRequestBodyEx` (exported from `Network.Wai.Parse`) throw `RequestParseException` rather than calling `error`. * `defaultGzipSettings` now exported to not depend on `Data.Default` [#959](https://github.com/yesodweb/wai/pull/959) ## 3.1.13.0 diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs --- a/Network/Wai/Handler/CGI.hs +++ b/Network/Wai/Handler/CGI.hs @@ -1,17 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} + -- | Backend for Common Gateway Interface. Almost all users should use the -- 'run' function. -module Network.Wai.Handler.CGI - ( run - , runSendfile - , runGeneric - , requestBodyFunc - ) where +module Network.Wai.Handler.CGI ( + run, + runSendfile, + runGeneric, + requestBodyFunc, +) where -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mconcat, mempty, mappend) -#endif import Control.Arrow ((***)) import Control.Monad (unless, void) import Data.ByteString.Builder (byteString, string8, toLazyByteString, word8) @@ -24,6 +22,9 @@ import Data.Function (fix) import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mconcat, mempty, mappend) +#endif import qualified Data.Streaming.ByteString.Builder as Builder import qualified Data.String as String import Data.Word8 (_lf, _space) @@ -46,9 +47,9 @@ safeRead :: Read a => a -> String -> a safeRead d s = - case reads s of - ((x, _):_) -> x - [] -> d + case reads s of + ((x, _) : _) -> x + [] -> d lookup' :: String -> [(String, String)] -> String lookup' key pairs = fromMaybe "" $ lookup key pairs @@ -64,8 +65,11 @@ -- | Some web servers provide an optimization for sending files via a sendfile -- system call via a special header. To use this feature, provide that header -- name here. -runSendfile :: B.ByteString -- ^ sendfile header - -> Application -> IO () +runSendfile + :: B.ByteString + -- ^ sendfile header + -> Application + -> IO () runSendfile sf app = do vars <- getEnvironment let input = requestBodyHandle System.IO.stdin @@ -76,12 +80,16 @@ -- use the same code as CGI. Most users will not need this function, and can -- stick with 'run' or 'runSendfile'. runGeneric - :: [(String, String)] -- ^ all variables - -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input - -> (B.ByteString -> IO ()) -- ^ destination for output - -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? - -> Application - -> IO () + :: [(String, String)] + -- ^ all variables + -> (Int -> IO (IO B.ByteString)) + -- ^ responseBody of input + -> (B.ByteString -> IO ()) + -- ^ destination for output + -> Maybe B.ByteString + -- ^ does the server support the X-Sendfile header? + -> Application + -> IO () runGeneric vars inputH outputH xsendfile app = do let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars @@ -99,29 +107,30 @@ requestBody' <- inputH contentLength let addr = case addrs of - a:_ -> addrAddress a + a : _ -> addrAddress a [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' reqHeaders = map (cleanupVarName *** B.pack) vars env = - setRequestBodyChunks requestBody' $ defaultRequest - { requestMethod = rmethod - , rawPathInfo = B.pack pinfo - , pathInfo = H.decodePathSegments $ B.pack pinfo - , rawQueryString = B.pack qstring - , queryString = H.parseQuery $ B.pack qstring - , requestHeaders = reqHeaders - , isSecure = isSecure' - , remoteHost = addr - , httpVersion = H.http11 -- FIXME - , vault = mempty - , requestBodyLength = KnownLength $ fromIntegral contentLength - , requestHeaderHost = lookup "host" reqHeaders - , requestHeaderRange = lookup hRange reqHeaders + setRequestBodyChunks requestBody' $ + defaultRequest + { requestMethod = rmethod + , rawPathInfo = B.pack pinfo + , pathInfo = H.decodePathSegments $ B.pack pinfo + , rawQueryString = B.pack qstring + , queryString = H.parseQuery $ B.pack qstring + , requestHeaders = reqHeaders + , isSecure = isSecure' + , remoteHost = addr + , httpVersion = H.http11 -- FIXME + , vault = mempty + , requestBodyLength = KnownLength $ fromIntegral contentLength + , requestHeaderHost = lookup "host" reqHeaders + , requestHeaderRange = lookup hRange reqHeaders #if MIN_VERSION_wai(3,2,0) - , requestHeaderReferer = lookup "referer" reqHeaders - , requestHeaderUserAgent = lookup "user-agent" reqHeaders + , requestHeaderReferer = lookup "referer" reqHeaders + , requestHeaderUserAgent = lookup "user-agent" reqHeaders #endif - } + } void $ app env $ \res -> case (xsendfile, res) of (Just sf, ResponseFile s hs fp Nothing) -> do @@ -144,25 +153,30 @@ return ResponseReceived where headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) - status (Status i m) = (byteString "Status", mconcat - [ string8 $ show i - , word8 _space - , byteString m - ]) + status (Status i m) = + ( byteString "Status" + , mconcat + [ string8 $ show i + , word8 _space + , byteString m + ] + ) header' (x, y) = (byteString $ CI.original x, byteString y) - header (x, y) = mconcat - [ x - , byteString ": " - , y - , word8 _lf - ] - sfBuilder s hs sf fp = mconcat - [ headers s hs - , header (byteString sf, string8 fp) - , word8 _lf - , byteString sf - , byteString " not supported" - ] + header (x, y) = + mconcat + [ x + , byteString ": " + , y + , word8 _lf + ] + sfBuilder s hs sf fp = + mconcat + [ headers s hs + , header (byteString sf, string8 fp) + , word8 _lf + , byteString sf + , byteString " not supported" + ] fixHeaders h = case lookup hContentType h of Nothing -> (hContentType, "text/html; charset=utf-8") : h @@ -174,11 +188,11 @@ cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name" cleanupVarName s = case s of - 'H':'T':'T':'P':'_':a:as -> String.fromString $ a : helper' as + 'H' : 'T' : 'T' : 'P' : '_' : a : as -> String.fromString $ a : helper' as _ -> String.fromString s -- FIXME remove? where - helper' ('_':x:rest) = '-' : x : helper' rest - helper' (x:rest) = toLower x : helper' rest + helper' ('_' : x : rest) = '-' : x : helper' rest + helper' (x : rest) = toLower x : helper' rest helper' [] = [] requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString) @@ -186,7 +200,8 @@ bs <- B.hGet h i return $ if B.null bs then Nothing else Just bs -requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString) +requestBodyFunc + :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString) requestBodyFunc get count0 = do ref <- newIORef count0 return $ do diff --git a/Network/Wai/Middleware/Local.hs b/Network/Wai/Middleware/Local.hs --- a/Network/Wai/Middleware/Local.hs +++ b/Network/Wai/Middleware/Local.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} + -- | Only allow local connections. --- -module Network.Wai.Middleware.Local - ( local - ) where +module Network.Wai.Middleware.Local ( + local, +) where import Network.Socket (SockAddr (..)) import Network.Wai (Middleware, Response, remoteHost) @@ -11,15 +11,15 @@ -- | This middleware rejects non-local connections with a specific response. -- It is useful when supporting web-based local applications, which would -- typically want to reject external connections. - local :: Response -> Middleware local resp f r k = case remoteHost r of - SockAddrInet _ h | h == fromIntegral home - -> f r k + SockAddrInet _ h + | h == fromIntegral home -> + f r k #if !defined(mingw32_HOST_OS) && !defined(_WIN32) - SockAddrUnix _ -> f r k + SockAddrUnix _ -> f r k #endif - _ -> k resp - where - home :: Integer - home = 127 + (256 * 256 * 256) + _ -> k resp + where + home :: Integer + home = 127 + (256 * 256 * 256) diff --git a/Network/Wai/Middleware/ValidateHeaders.hs b/Network/Wai/Middleware/ValidateHeaders.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -1,70 +1,76 @@ {-# LANGUAGE CPP #-} -{-# language DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} -{-# language LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} --- | Some helpers for parsing data out of a raw WAI 'Request'. +{-# LANGUAGE TypeFamilies #-} -module Network.Wai.Parse - ( parseHttpAccept - , parseRequestBody - , RequestBodyType (..) - , getRequestBodyType - , sinkRequestBody - , sinkRequestBodyEx - , RequestParseException(..) - , BackEnd - , lbsBackEnd - , tempFileBackEnd - , tempFileBackEndOpts - , Param - , File - , FileInfo (..) - , parseContentType - , ParseRequestBodyOptions - , defaultParseRequestBodyOptions - , noLimitParseRequestBodyOptions - , parseRequestBodyEx - , setMaxRequestKeyLength - , clearMaxRequestKeyLength - , setMaxRequestNumFiles - , clearMaxRequestNumFiles - , setMaxRequestFileSize - , clearMaxRequestFileSize - , setMaxRequestFilesSize - , clearMaxRequestFilesSize - , setMaxRequestParmsSize - , clearMaxRequestParmsSize - , setMaxHeaderLines - , clearMaxHeaderLines - , setMaxHeaderLineLength - , clearMaxHeaderLineLength +-- | Some helpers for parsing data out of a raw WAI 'Request'. +module Network.Wai.Parse ( + parseHttpAccept, + parseRequestBody, + RequestBodyType (..), + getRequestBodyType, + sinkRequestBody, + sinkRequestBodyEx, + RequestParseException (..), + BackEnd, + lbsBackEnd, + tempFileBackEnd, + tempFileBackEndOpts, + Param, + File, + FileInfo (..), + parseContentType, + ParseRequestBodyOptions, + defaultParseRequestBodyOptions, + noLimitParseRequestBodyOptions, + parseRequestBodyEx, + setMaxRequestKeyLength, + clearMaxRequestKeyLength, + setMaxRequestNumFiles, + clearMaxRequestNumFiles, + setMaxRequestFileSize, + clearMaxRequestFileSize, + setMaxRequestFilesSize, + clearMaxRequestFilesSize, + setMaxRequestParmsSize, + clearMaxRequestParmsSize, + setMaxHeaderLines, + clearMaxHeaderLines, + setMaxHeaderLineLength, + clearMaxHeaderLineLength, #if TEST - , Bound (..) - , findBound - , sinkTillBound - , killCR - , killCRLF - , takeLine + Bound (..), + findBound, + sinkTillBound, + killCR, + killCRLF, + takeLine, #endif - ) where +) where import Prelude hiding (lines) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif -import Data.CaseInsensitive (mk) import Control.Exception (catchJust) import qualified Control.Exception as E import Control.Monad (guard, unless, when) -import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState) +import Control.Monad.Trans.Resource ( + InternalState, + allocate, + register, + release, + runInternalState, + ) import Data.Bifunctor (bimap) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive (mk) import Data.Function (fix, on) import Data.IORef import Data.Int (Int64) @@ -75,7 +81,7 @@ import Network.HTTP.Types (hContentType) import qualified Network.HTTP.Types as H import Network.Wai -import Network.Wai.Handler.Warp (InvalidRequest(..)) +import Network.Wai.Handler.Warp (InvalidRequest (..)) import System.Directory (getTemporaryDirectory, removeFile) import System.IO (hClose, openBinaryTempFile) import System.IO.Error (isDoesNotExistError) @@ -87,18 +93,19 @@ -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: S.ByteString -> [S.ByteString] -parseHttpAccept = map fst - . sortBy (rcompare `on` snd) - . map (addSpecificity . grabQ) - . S.split _comma +parseHttpAccept = + map fst + . sortBy (rcompare `on` snd) + . map (addSpecificity . grabQ) + . S.split _comma where - rcompare :: (Double,Int) -> (Double,Int) -> Ordering + rcompare :: (Double, Int) -> (Double, Int) -> Ordering rcompare = flip compare addSpecificity (s, q) = -- Prefer higher-specificity types let semicolons = S.count _semicolon s stars = S.count _asterisk s - in (s, (q, semicolons - stars)) + in (s, (q, semicolons - stars)) grabQ s = -- Stripping all spaces may be too harsh. -- Maybe just strip either side of semicolon? @@ -106,11 +113,12 @@ q' = S.takeWhile (/= _semicolon) (S.drop 3 q) in (s', readQ q') readQ s = case reads $ S8.unpack s of - (x, _):_ -> x - _ -> 1.0 + (x, _) : _ -> x + _ -> 1.0 -- | Store uploaded files in memory -lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString +lbsBackEnd + :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString lbsBackEnd _ _ popper = loop id where @@ -118,26 +126,31 @@ bs <- popper if S.null bs then return $ L.fromChunks $ front [] - else loop $ front . (bs:) + else loop $ front . (bs :) -- | Save uploaded files on disk as temporary files -- -- Note: starting with version 2.0, removal of temp files is registered with -- the provided @InternalState@. It is the responsibility of the caller to -- ensure that this @InternalState@ gets cleaned up. -tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath +tempFileBackEnd + :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf" -- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns. -tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory - -> String -- ^ filename pattern - -> InternalState - -> ignored1 - -> ignored2 - -> IO S.ByteString - -> IO FilePath +tempFileBackEndOpts + :: IO FilePath + -- ^ get temporary directory + -> String + -- ^ filename pattern + -> InternalState + -> ignored1 + -> ignored2 + -> IO S.ByteString + -> IO FilePath tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do - (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd) + (key, (fp, h)) <- + flip runInternalState internalState $ allocate it (hClose . snd) _ <- runInternalState (register $ removeFileQuiet fp) internalState fix $ \loop -> do bs <- popper @@ -146,117 +159,126 @@ loop release key return fp - where - it = do - tempDir <- getTmpDir - openBinaryTempFile tempDir pattrn - removeFileQuiet fp = catchJust (guard . isDoesNotExistError) - (removeFile fp) - (const $ return ()) + where + it = do + tempDir <- getTmpDir + openBinaryTempFile tempDir pattrn + removeFileQuiet fp = + catchJust + (guard . isDoesNotExistError) + (removeFile fp) + (const $ return ()) -- | A data structure that describes the behavior of -- the parseRequestBodyEx function. -- -- @since 3.0.16.0 data ParseRequestBodyOptions = ParseRequestBodyOptions - { -- | The maximum length of a filename - prboKeyLength :: Maybe Int - , -- | The maximum number of files. - prboMaxNumFiles :: Maybe Int - , -- | The maximum filesize per file. - prboMaxFileSize :: Maybe Int64 - , -- | The maximum total filesize. - prboMaxFilesSize :: Maybe Int64 - , -- | The maximum size of the sum of all parameters - prboMaxParmsSize :: Maybe Int - , -- | The maximum header lines per mime/multipart entry - prboMaxHeaderLines :: Maybe Int - , -- | The maximum header line length per mime/multipart entry - prboMaxHeaderLineLength :: Maybe Int } + { prboKeyLength :: Maybe Int + -- ^ The maximum length of a filename + , prboMaxNumFiles :: Maybe Int + -- ^ The maximum number of files. + , prboMaxFileSize :: Maybe Int64 + -- ^ The maximum filesize per file. + , prboMaxFilesSize :: Maybe Int64 + -- ^ The maximum total filesize. + , prboMaxParmsSize :: Maybe Int + -- ^ The maximum size of the sum of all parameters + , prboMaxHeaderLines :: Maybe Int + -- ^ The maximum header lines per mime/multipart entry + , prboMaxHeaderLineLength :: Maybe Int + -- ^ The maximum header line length per mime/multipart entry + } -- | Set the maximum length of a filename. -- -- @since 3.0.16.0 -setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxRequestKeyLength l p = p { prboKeyLength=Just l } +setMaxRequestKeyLength + :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions +setMaxRequestKeyLength l p = p{prboKeyLength = Just l} -- | Do not limit the length of filenames. -- -- @since 3.0.16.0 clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxRequestKeyLength p = p { prboKeyLength=Nothing } +clearMaxRequestKeyLength p = p{prboKeyLength = Nothing} -- | Set the maximum number of files per request. -- -- @since 3.0.16.0 -setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l } +setMaxRequestNumFiles + :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions +setMaxRequestNumFiles l p = p{prboMaxNumFiles = Just l} -- | Do not limit the maximum number of files per request. -- -- @since 3.0.16.0 clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing } +clearMaxRequestNumFiles p = p{prboMaxNumFiles = Nothing} -- | Set the maximum filesize per file (in bytes). -- -- @since 3.0.16.0 -setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxRequestFileSize l p = p { prboMaxFileSize=Just l } +setMaxRequestFileSize + :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions +setMaxRequestFileSize l p = p{prboMaxFileSize = Just l} -- | Do not limit the maximum filesize per file. -- -- @since 3.0.16.0 clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing } +clearMaxRequestFileSize p = p{prboMaxFileSize = Nothing} -- | Set the maximum size of all files per request. -- -- @since 3.0.16.0 -setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l } +setMaxRequestFilesSize + :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions +setMaxRequestFilesSize l p = p{prboMaxFilesSize = Just l} -- | Do not limit the maximum size of all files per request. -- -- @since 3.0.16.0 clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing } +clearMaxRequestFilesSize p = p{prboMaxFilesSize = Nothing} -- | Set the maximum size of the sum of all parameters. -- -- @since 3.0.16.0 -setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l } +setMaxRequestParmsSize + :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions +setMaxRequestParmsSize l p = p{prboMaxParmsSize = Just l} -- | Do not limit the maximum size of the sum of all parameters. -- -- @since 3.0.16.0 clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing } +clearMaxRequestParmsSize p = p{prboMaxParmsSize = Nothing} -- | Set the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l } +setMaxHeaderLines l p = p{prboMaxHeaderLines = Just l} -- | Do not limit the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 -clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing } +clearMaxHeaderLines :: ParseRequestBodyOptions -> ParseRequestBodyOptions +clearMaxHeaderLines p = p{prboMaxHeaderLines = Nothing} -- | Set the maximum header line length per mime/multipart entry. -- -- @since 3.0.16.0 -setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions -setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l } +setMaxHeaderLineLength + :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions +setMaxHeaderLineLength l p = p{prboMaxHeaderLineLength = Just l} -- | Do not limit the maximum header lines per mime/multipart entry. -- -- @since 3.0.16.0 clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions -clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing } +clearMaxHeaderLineLength p = p{prboMaxHeaderLineLength = Nothing} -- | A reasonable default set of parsing options. -- Maximum key/filename length: 32 bytes; @@ -269,27 +291,31 @@ -- -- @since 3.0.16.0 defaultParseRequestBodyOptions :: ParseRequestBodyOptions -defaultParseRequestBodyOptions = ParseRequestBodyOptions - { prboKeyLength=Just 32 - , prboMaxNumFiles=Just 10 - , prboMaxFileSize=Nothing - , prboMaxFilesSize=Nothing - , prboMaxParmsSize=Just 65336 - , prboMaxHeaderLines=Just 32 - , prboMaxHeaderLineLength=Just 8190 } +defaultParseRequestBodyOptions = + ParseRequestBodyOptions + { prboKeyLength = Just 32 + , prboMaxNumFiles = Just 10 + , prboMaxFileSize = Nothing + , prboMaxFilesSize = Nothing + , prboMaxParmsSize = Just 65336 + , prboMaxHeaderLines = Just 32 + , prboMaxHeaderLineLength = Just 8190 + } -- | Do not impose any memory limits. -- -- @since 3.0.21.0 noLimitParseRequestBodyOptions :: ParseRequestBodyOptions -noLimitParseRequestBodyOptions = ParseRequestBodyOptions - { prboKeyLength=Nothing - , prboMaxNumFiles=Nothing - , prboMaxFileSize=Nothing - , prboMaxFilesSize=Nothing - , prboMaxParmsSize=Nothing - , prboMaxHeaderLines=Nothing - , prboMaxHeaderLineLength=Nothing } +noLimitParseRequestBodyOptions = + ParseRequestBodyOptions + { prboKeyLength = Nothing + , prboMaxNumFiles = Nothing + , prboMaxFileSize = Nothing + , prboMaxFilesSize = Nothing + , prboMaxParmsSize = Nothing + , prboMaxHeaderLines = Nothing + , prboMaxHeaderLineLength = Nothing + } -- | Information on an uploaded file. data FileInfo c = FileInfo @@ -307,10 +333,12 @@ -- | A file uploading backend. Takes the parameter name, file name, and a -- stream of data. -type BackEnd a = S.ByteString -- ^ parameter name - -> FileInfo () - -> IO S.ByteString - -> IO a +type BackEnd a = + S.ByteString + -- ^ parameter name + -> FileInfo () + -> IO S.ByteString + -> IO a -- | The mimetype of the http body. -- Depending on whether just parameters or parameters and files @@ -335,20 +363,22 @@ -- content type and a list of pairs of attributes. -- -- @since 1.3.2 -parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)]) +parseContentType + :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)]) parseContentType a = do let (ctype, b) = S.break (== _semicolon) a attrs = goAttrs id $ S.drop 1 b in (ctype, attrs) where - dq s = if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl - then S.tail $ S.init s - else s + dq s = + if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl + then S.tail $ S.init s + else s goAttrs front bs | S.null bs = front [] | otherwise = let (x, rest) = S.break (== _semicolon) bs - in goAttrs (front . (goAttr x:)) $ S.drop 1 rest + in goAttrs (front . (goAttr x :)) $ S.drop 1 rest goAttr bs = let (k, v') = S.break (== _equal) bs v = S.drop 1 v' @@ -363,9 +393,10 @@ -- use the 'parseRequestBodyEx' function instead. -- -- since 3.1.15 : throws 'RequestParseException' if something goes wrong -parseRequestBody :: BackEnd y - -> Request - -> IO ([Param], [File y]) +parseRequestBody + :: BackEnd y + -> Request + -> IO ([Param], [File y]) parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions -- | Parse the body of an HTTP request, limit resource usage. @@ -376,20 +407,22 @@ -- is responsible for storing the received files. -- -- since 3.1.15 : throws 'RequestParseException' if something goes wrong -parseRequestBodyEx :: ParseRequestBodyOptions - -> BackEnd y - -> Request - -> IO ([Param], [File y]) +parseRequestBodyEx + :: ParseRequestBodyOptions + -> BackEnd y + -> Request + -> IO ([Param], [File y]) parseRequestBodyEx o s r = case getRequestBodyType r of Nothing -> return ([], []) Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r) -- | since 3.1.15 : throws 'RequestParseException' if something goes wrong -sinkRequestBody :: BackEnd y - -> RequestBodyType - -> IO S.ByteString - -> IO ([Param], [File y]) +sinkRequestBody + :: BackEnd y + -> RequestBodyType + -> IO S.ByteString + -> IO ([Param], [File y]) sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions -- | Throws 'RequestParseException' if something goes wrong @@ -397,26 +430,28 @@ -- @since 3.0.16.0 -- -- since 3.1.15 : throws 'RequestParseException' if something goes wrong -sinkRequestBodyEx :: ParseRequestBodyOptions - -> BackEnd y - -> RequestBodyType - -> IO S.ByteString - -> IO ([Param], [File y]) +sinkRequestBodyEx + :: ParseRequestBodyOptions + -> BackEnd y + -> RequestBodyType + -> IO S.ByteString + -> IO ([Param], [File y]) sinkRequestBodyEx o s r body = do ref <- newIORef ([], []) let add x = atomicModifyIORef ref $ \(y, z) -> case x of - Left y' -> ((y':y, z), ()) - Right z' -> ((y, z':z), ()) + Left y' -> ((y' : y, z), ()) + Right z' -> ((y, z' : z), ()) conduitRequestBodyEx o s r body add bimap reverse reverse <$> readIORef ref -conduitRequestBodyEx :: ParseRequestBodyOptions - -> BackEnd y - -> RequestBodyType - -> IO S.ByteString - -> (Either Param (File y) -> IO ()) - -> IO () +conduitRequestBodyEx + :: ParseRequestBodyOptions + -> BackEnd y + -> RequestBodyType + -> IO S.ByteString + -> (Either Param (File y) -> IO ()) + -> IO () conduitRequestBodyEx o _ UrlEncoded rbody add = do -- NOTE: in general, url-encoded data will be in a single chunk. -- Therefore, I'm optimizing for the usual case by sticking with @@ -428,16 +463,17 @@ else do let newsize = size + S.length bs case prboMaxParmsSize o of - Just maxSize -> when (newsize > maxSize) $ - E.throwIO $ MaxParamSizeExceeded newsize + Just maxSize -> + when (newsize > maxSize) $ + E.throwIO $ + MaxParamSizeExceeded newsize Nothing -> return () - loop newsize $ front . (bs:) + loop newsize $ front . (bs :) bs <- loop 0 id mapM_ (add . Left) $ H.parseSimpleQuery bs conduitRequestBodyEx o backend (Multipart bound) rbody add = parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add - -- | Take one header or subheader line. -- Since: 3.0.26 -- Throw 431 if headers too large. @@ -448,8 +484,9 @@ go front = do bs <- readSource src case maxlen of - Just maxlen' -> when (S.length front > maxlen') $ - E.throwIO RequestHeaderFieldsTooLarge + Just maxlen' -> + when (S.length front > maxlen') $ + E.throwIO RequestHeaderFieldsTooLarge Nothing -> return () if S.null bs then close front @@ -464,8 +501,9 @@ when (S.length y > 1) $ leftover src $ S.drop 1 y let res = front `S.append` x case maxlen of - Just maxlen' -> when (S.length res > maxlen') $ - E.throwIO RequestHeaderFieldsTooLarge + Just maxlen' -> + when (S.length res > maxlen') $ + E.throwIO RequestHeaderFieldsTooLarge Nothing -> return () return . Just $ killCR res @@ -485,14 +523,15 @@ case maxLines of Just maxLines' -> when (length lines > maxLines') $ - E.throwIO $ TooManyHeaderLines (length lines) + E.throwIO $ + TooManyHeaderLines (length lines) Nothing -> return () res <- takeLine lineLength src case res of Nothing -> return lines Just l | S.null l -> return lines - | otherwise -> takeLines'' (l:lines) lineLength maxLines src + | otherwise -> takeLines'' (l : lines) lineLength maxLines src data Source = Source (IO S.ByteString) (IORef S.ByteString) @@ -507,26 +546,31 @@ if S.null bs then f else return bs + {- HLint ignore readSource "Use tuple-section" -} leftover :: Source -> S.ByteString -> IO () leftover (Source _ ref) = writeIORef ref -- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong -parsePiecesEx :: ParseRequestBodyOptions - -> BackEnd y - -> S.ByteString - -> IO S.ByteString - -> (Either Param (File y) -> IO ()) - -> IO () +parsePiecesEx + :: ParseRequestBodyOptions + -> BackEnd y + -> S.ByteString + -> IO S.ByteString + -> (Either Param (File y) -> IO ()) + -> IO () parsePiecesEx o sink bound rbody add = mkSource rbody >>= loop 0 0 0 0 where loop :: Int -> Int -> Int -> Int64 -> Source -> IO () loop numParms numFiles parmSize filesSize src = do _boundLine <- takeLine (prboMaxHeaderLineLength o) src - res' <- takeLines' (prboMaxHeaderLineLength o) - (prboMaxHeaderLines o) src + res' <- + takeLines' + (prboMaxHeaderLineLength o) + (prboMaxHeaderLines o) + src unless (null res') $ do let ls' = map parsePair res' let x = do @@ -540,41 +584,60 @@ case prboKeyLength o of Just maxKeyLength -> when (S.length name > maxKeyLength) $ - E.throwIO $ FilenameTooLong name maxKeyLength + E.throwIO $ + FilenameTooLong name maxKeyLength Nothing -> return () case prboMaxNumFiles o of - Just maxFiles -> when (numFiles >= maxFiles) $ - E.throwIO $ MaxFileNumberExceeded numFiles + Just maxFiles -> + when (numFiles >= maxFiles) $ + E.throwIO $ + MaxFileNumberExceeded numFiles Nothing -> return () let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct () - fs = catMaybes [ prboMaxFileSize o - , subtract filesSize <$> prboMaxFilesSize o ] + fs = + catMaybes + [ prboMaxFileSize o + , subtract filesSize <$> prboMaxFilesSize o + ] mfs = if null fs then Nothing else Just $ minimum fs ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs let newFilesSize = filesSize + fileSize - add $ Right (name, fi0 { fileContent = y }) + add $ Right (name, fi0{fileContent = y}) when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src Just (_ct, name, Nothing) -> do case prboKeyLength o of Just maxKeyLength -> when (S.length name > maxKeyLength) $ - E.throwIO $ ParamNameTooLong name maxKeyLength + E.throwIO $ + ParamNameTooLong name maxKeyLength Nothing -> return () let seed = id let iter front bs = return $ front . (:) bs - ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src - (fromIntegral <$> prboMaxParmsSize o) + ((wasFound, _fileSize), front) <- + sinkTillBound + bound + iter + seed + src + (fromIntegral <$> prboMaxParmsSize o) let bs = S.concat $ front [] let x' = (name, bs) let newParmSize = parmSize + S.length name + S.length bs case prboMaxParmsSize o of - Just maxParmSize -> when (newParmSize > maxParmSize) $ - E.throwIO $ MaxParamSizeExceeded newParmSize + Just maxParmSize -> + when (newParmSize > maxParmSize) $ + E.throwIO $ + MaxParamSizeExceeded newParmSize Nothing -> return () add $ Left x' - when wasFound $ loop (numParms + 1) numFiles - newParmSize filesSize src + when wasFound $ + loop + (numParms + 1) + numFiles + newParmSize + filesSize + src _ -> do -- ignore this part let seed = () @@ -591,40 +654,42 @@ -- | Things that could go wrong while parsing a 'Request' -- -- @since 3.1.15 -data RequestParseException = MaxParamSizeExceeded Int - | ParamNameTooLong S.ByteString Int - | MaxFileNumberExceeded Int - | FilenameTooLong S.ByteString Int - | TooManyHeaderLines Int - deriving (Eq, Typeable) +data RequestParseException + = MaxParamSizeExceeded Int + | ParamNameTooLong S.ByteString Int + | MaxFileNumberExceeded Int + | FilenameTooLong S.ByteString Int + | TooManyHeaderLines Int + deriving (Eq, Typeable) + instance E.Exception RequestParseException instance Show RequestParseException where - show = \case - MaxParamSizeExceeded lmax -> unwords ["maximum parameter size exceeded:", show lmax] - ParamNameTooLong s lmax -> unwords ["parameter name", S8.unpack s, "is too long:", show lmax] - MaxFileNumberExceeded lmax -> unwords ["maximum number of files exceeded:", show lmax] - FilenameTooLong fn lmax -> - unwords ["file name", S8.unpack fn, "too long:", show lmax] - TooManyHeaderLines nmax -> unwords ["Too many lines in mime/multipart header:", show nmax] - + show = \case + MaxParamSizeExceeded lmax -> unwords ["maximum parameter size exceeded:", show lmax] + ParamNameTooLong s lmax -> unwords ["parameter name", S8.unpack s, "is too long:", show lmax] + MaxFileNumberExceeded lmax -> unwords ["maximum number of files exceeded:", show lmax] + FilenameTooLong fn lmax -> + unwords ["file name", S8.unpack fn, "too long:", show lmax] + TooManyHeaderLines nmax -> unwords ["Too many lines in mime/multipart header:", show nmax] -data Bound = FoundBound S.ByteString S.ByteString - | NoBound - | PartialBound +data Bound + = FoundBound S.ByteString S.ByteString + | NoBound + | PartialBound deriving (Eq, Show) findBound :: S.ByteString -> S.ByteString -> Bound findBound b bs = handleBreak $ S.breakSubstring b bs where handleBreak (h, t) - | S.null t = go [lowBound..S.length bs - 1] + | S.null t = go [lowBound .. S.length bs - 1] | otherwise = FoundBound h $ S.drop (S.length b) t lowBound = max 0 $ S.length bs - S.length b go [] = NoBound - go (i:is) - | mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is + go (i : is) + | mismatch [0 .. S.length b - 1] [i .. S.length bs - 1] = go is | otherwise = let endI = i + S.length b in if endI > S.length bs @@ -632,29 +697,34 @@ else FoundBound (S.take i bs) (S.drop endI bs) mismatch [] _ = False mismatch _ [] = False - mismatch (x:xs) (y:ys) + mismatch (x : xs) (y : ys) | S.index b x == S.index bs y = mismatch xs ys | otherwise = True -sinkTillBound' :: S.ByteString - -> S.ByteString - -> FileInfo () - -> BackEnd y - -> Source - -> Maybe Int64 - -> IO ((Bool, Int64), y) +sinkTillBound' + :: S.ByteString + -> S.ByteString + -> FileInfo () + -> BackEnd y + -> Source + -> Maybe Int64 + -> IO ((Bool, Int64), y) sinkTillBound' bound name fi sink src max' = do (next, final) <- wrapTillBound bound src max' y <- sink name fi next b <- final return (b, y) -data WTB = WTBWorking (S.ByteString -> S.ByteString) - | WTBDone Bool -wrapTillBound :: S.ByteString -- ^ bound - -> Source - -> Maybe Int64 - -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found +data WTB + = WTBWorking (S.ByteString -> S.ByteString) + | WTBDone Bool +wrapTillBound + :: S.ByteString + -- ^ bound + -> Source + -> Maybe Int64 + -> IO (IO S.ByteString, IO (Bool, Int64)) + -- ^ Bool indicates if the bound was found wrapTillBound bound src max' = do ref <- newIORef $ WTBWorking id sref <- newIORef (0 :: Int64) @@ -674,11 +744,11 @@ WTBDone _ -> return S.empty WTBWorking front -> do bs <- readSource src - cur <- atomicModifyIORef' sref $ \ cur -> + cur <- atomicModifyIORef' sref $ \cur -> let new = cur + fromIntegral (S.length bs) in (new, new) case max' of - Just max'' | cur > max'' -> E.throwIO PayloadTooLarge - _ -> return () + Just max'' | cur > max'' -> E.throwIO PayloadTooLarge + _ -> return () if S.null bs then do writeIORef ref $ WTBDone False @@ -695,9 +765,10 @@ NoBound -> do -- don't emit newlines, in case it's part of a bound let (toEmit, front') = - if not (S8.null bs) && S8.last bs `elem` ['\r','\n'] - then let (x, y) = S.splitAt (S.length bs - 2) bs - in (x, S.append y) + if not (S8.null bs) && S8.last bs `elem` ['\r', '\n'] + then + let (x, y) = S.splitAt (S.length bs - 2) bs + in (x, S.append y) else (bs, id) writeIORef ref $ WTBWorking front' if S.null toEmit @@ -707,12 +778,13 @@ writeIORef ref $ WTBWorking $ S.append bs go ref sref -sinkTillBound :: S.ByteString - -> (x -> S.ByteString -> IO x) - -> x - -> Source - -> Maybe Int64 - -> IO ((Bool, Int64), x) +sinkTillBound + :: S.ByteString + -> (x -> S.ByteString -> IO x) + -> x + -> Source + -> Maybe Int64 + -> IO ((Bool, Int64), x) sinkTillBound bound iter seed0 src max' = do (next, final) <- wrapTillBound bound src max' let loop seed = do @@ -728,9 +800,10 @@ parseAttrs = map go . S.split _semicolon where tw = S.dropWhile (== _space) - dq s = if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl - then S.tail $ S.init s - else s + dq s = + if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl + then S.tail $ S.init s + else s go s = let (x, y) = breakDiscard _equal s in (tw x, dq $ tw y) diff --git a/test/Network/Wai/Middleware/ValidateHeadersSpec.hs b/test/Network/Wai/Middleware/ValidateHeadersSpec.hs new file mode 100644 --- /dev/null +++ b/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 "" diff --git a/test/Network/Wai/TestSpec.hs b/test/Network/Wai/TestSpec.hs --- a/test/Network/Wai/TestSpec.hs +++ b/test/Network/Wai/TestSpec.hs @@ -145,27 +145,29 @@ ) it - "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do - sresp <- flip runSession cookieApp $ do - void $ + "sends a Cookie header with correct value after receiving a Set-Cookie header" + $ do + sresp <- flip runSession cookieApp $ do + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value" request $ - setPath defaultRequest "/set/cookie_name/cookie_value" - request $ - setPath defaultRequest "/get" - simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]" it - "sends a Cookie header with updated value after receiving a Set-Cookie header update" $ do - sresp <- flip runSession cookieApp $ do - void $ - request $ - setPath defaultRequest "/set/cookie_name/cookie_value" - void $ + "sends a Cookie header with updated value after receiving a Set-Cookie header update" + $ do + sresp <- flip runSession cookieApp $ do + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value" + void $ + request $ + setPath defaultRequest "/set/cookie_name/cookie_value2" request $ - setPath defaultRequest "/set/cookie_name/cookie_value2" - request $ - setPath defaultRequest "/get" - simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" + setPath defaultRequest "/get" + simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]" it "handles multiple cookies" $ do sresp <- flip runSession cookieApp $ do diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs --- a/test/WaiExtraSpec.hs +++ b/test/WaiExtraSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} + module WaiExtraSpec (spec, toRequest) where import Codec.Compression.GZip (decompress) @@ -40,7 +41,13 @@ import Network.Wai.Header (parseQValueList) import Network.Wai.Middleware.AcceptOverride (acceptOverride) import Network.Wai.Middleware.Autohead (autohead) -import Network.Wai.Middleware.Gzip (GzipFiles (..), GzipSettings (..), def, defaultCheckMime, gzip) +import Network.Wai.Middleware.Gzip ( + GzipFiles (..), + GzipSettings (..), + def, + defaultCheckMime, + gzip, + ) import Network.Wai.Middleware.Jsonp (jsonp) import Network.Wai.Middleware.MethodOverride (methodOverride) import Network.Wai.Middleware.MethodOverridePost (methodOverridePost) @@ -52,47 +59,50 @@ spec :: Spec spec = do - describe "Network.Wai.UrlMap" $ do - mapM_ (uncurry it) casesUrlMap + describe "Network.Wai.UrlMap" $ do + mapM_ (uncurry it) casesUrlMap - describe "Network.Wai" $ do - {- - , it "findBound" caseFindBound - , it "sinkTillBound" caseSinkTillBound - , it "killCR" caseKillCR - , it "killCRLF" caseKillCRLF - , it "takeLine" caseTakeLine - -} - it "jsonp" caseJsonp - describe "gzip" $ do - it "gzip" caseGzip - it "more gzip" caseGzip2 - it "gzip not on partial content" caseGzipPartial - it "gzip removes length header" caseGzipLength - it "gzip not for MSIE" caseGzipMSIE - it "gzip bypass when precompressed" caseGzipBypassPre - it "defaultCheckMime" caseDefaultCheckMime - it "gzip checking of files" caseGzipFiles - it "vhost" caseVhost - it "autohead" caseAutohead - it "method override" caseMethodOverride - it "method override post" caseMethodOverridePost - it "accept override" caseAcceptOverride - it "debug request body" caseDebugRequestBody - it "stream file" caseStreamFile - it "stream LBS" caseStreamLBS - it "can modify POST params before logging" caseModifyPostParamsInLogs - it "can filter requests in logs" caseFilterRequestsInLogs - it "can parse Q values" caseQValues + describe "Network.Wai" $ do + {- + , it "findBound" caseFindBound + , it "sinkTillBound" caseSinkTillBound + , it "killCR" caseKillCR + , it "killCRLF" caseKillCRLF + , it "takeLine" caseTakeLine + -} + it "jsonp" caseJsonp + describe "gzip" $ do + it "gzip" caseGzip + it "more gzip" caseGzip2 + it "gzip not on partial content" caseGzipPartial + it "gzip removes length header" caseGzipLength + it "gzip not for MSIE" caseGzipMSIE + it "gzip bypass when precompressed" caseGzipBypassPre + it "defaultCheckMime" caseDefaultCheckMime + it "gzip checking of files" caseGzipFiles + it "vhost" caseVhost + it "autohead" caseAutohead + it "method override" caseMethodOverride + it "method override post" caseMethodOverridePost + it "accept override" caseAcceptOverride + it "debug request body" caseDebugRequestBody + it "stream file" caseStreamFile + it "stream LBS" caseStreamLBS + it "can modify POST params before logging" caseModifyPostParamsInLogs + it "can filter requests in logs" caseFilterRequestsInLogs + it "can parse Q values" caseQValues toRequest :: S8.ByteString -> S8.ByteString -> SRequest -toRequest ctype content = SRequest defaultRequest - { requestHeaders = [("Content-Type", ctype)] - , requestMethod = "POST" - , rawPathInfo = "/" - , rawQueryString = "" - , queryString = [] - } (L.fromChunks [content]) +toRequest ctype content = + SRequest + defaultRequest + { requestHeaders = [("Content-Type", ctype)] + , requestMethod = "POST" + , rawPathInfo = "/" + , rawQueryString = "" + , queryString = [] + } + (L.fromChunks [content]) {- caseFindBound :: Assertion @@ -146,28 +156,36 @@ -} jsonpApp :: Application -jsonpApp = jsonp $ \_ f -> f $ responseLBS - status200 - [("Content-Type", "application/json")] - "{\"foo\":\"bar\"}" +jsonpApp = jsonp $ \_ f -> + f $ + responseLBS + status200 + [("Content-Type", "application/json")] + "{\"foo\":\"bar\"}" caseJsonp :: Assertion caseJsonp = withSession jsonpApp $ do - sres1 <- request defaultRequest + sres1 <- + request + defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "text/javascript" sres1 assertBody "test({\"foo\":\"bar\"})" sres1 - sres2 <- request defaultRequest + sres2 <- + request + defaultRequest { queryString = [("call_back", Just "test")] , requestHeaders = [("Accept", "text/javascript")] } assertContentType "application/json" sres2 assertBody "{\"foo\":\"bar\"}" sres2 - sres3 <- request defaultRequest + sres3 <- + request + defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/html")] } @@ -179,9 +197,12 @@ gzipApp' :: (Response -> Response) -> Application gzipApp' changeRes = - gzip def $ \_ f -> f . changeRes $ responseLBS status200 - [("Content-Type", "text/plain")] - "test" + gzip def $ \_ f -> + f . changeRes $ + responseLBS + status200 + [("Content-Type", "text/plain")] + "test" gzipAppWithHeaders :: ResponseHeaders -> Application gzipAppWithHeaders hdrs = gzipApp' $ mapResponseHeaders (hdrs ++) @@ -205,8 +226,9 @@ -- | Use 'changeRes' to make r gzipFileApp' :: GzipSettings -> (Response -> Response) -> Application gzipFileApp' set changeRes = - gzip set $ \_ f -> f . changeRes $ - responseFile status200 [(hContentType, "application/json")] gzipJSONFile Nothing + gzip set $ \_ f -> + f . changeRes $ + responseFile status200 [(hContentType, "application/json")] gzipJSONFile Nothing acceptGzip :: Header acceptGzip = (hAcceptEncoding, "gzip") @@ -222,9 +244,11 @@ doesEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse doesEncodeGzip' body hdrs = do - sres <- request defaultRequest - { requestHeaders = hdrs - } + sres <- + request + defaultRequest + { requestHeaders = hdrs + } assertHeader hContentEncoding "gzip" sres assertHeader hVary "Accept-Encoding" sres liftIO $ decompress (simpleBody sres) @?= body @@ -241,9 +265,11 @@ doesNotEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse doesNotEncodeGzip' body hdrs = do - sres <- request defaultRequest - { requestHeaders = hdrs - } + sres <- + request + defaultRequest + { requestHeaders = hdrs + } assertNoHeader hContentEncoding sres assertHeader hVary "Accept-Encoding" sres assertBody body sres @@ -280,15 +306,19 @@ caseGzip2 :: Assertion caseGzip2 = withSession gzipVariantApp $ do - sres1 <- request defaultRequest - { requestHeaders = [(hAcceptEncoding, "compress, gzip")] } + sres1 <- + request + defaultRequest + { requestHeaders = [(hAcceptEncoding, "compress, gzip")] + } assertHeader hContentEncoding "compress" sres1 assertHeader hVary "Accept-Encoding, foobar" sres1 where - gzipVariantApp = gzipAppWithHeaders - [ ("Content-Encoding", "compress") - , ("Vary", "foobar") - ] + gzipVariantApp = + gzipAppWithHeaders + [ ("Content-Encoding", "compress") + , ("Vary", "foobar") + ] -- | Testing of the GzipSettings's 'GzipFiles' setting -- with 'ResponseFile' responses. @@ -308,8 +338,11 @@ -- Checks for a "filename.gz" file in the same folder withSession (gzipFileApp def{gzipFiles = GzipPreCompressed GzipIgnore}) $ do - sres <- request defaultRequest - { requestHeaders = [acceptGzip] } + sres <- + request + defaultRequest + { requestHeaders = [acceptGzip] + } assertHeader hContentEncoding "gzip" sres assertHeader hVary "Accept-Encoding" sres -- json.gz has body "test\n" @@ -363,11 +396,16 @@ withSession (gzipFileApp def{gzipFiles = GzipCacheFolder path}) $ do _ <- doesEncodeGzipJSON [acceptGzip] liftIO $ checkTempDir 2 "just to make sure it isn't a fluke" - where - noPreCompressApp set = gzipFileApp' - def{gzipFiles = set} - $ const $ responseFile status200 [(hContentType, "text/plain")] gzipNoPreCompressFile Nothing + noPreCompressApp set = + gzipFileApp' + def{gzipFiles = set} + $ const + $ responseFile + status200 + [(hContentType, "text/plain")] + gzipNoPreCompressFile + Nothing caseDefaultCheckMime :: Assertion caseDefaultCheckMime = do @@ -381,10 +419,11 @@ caseGzipMSIE :: Assertion caseGzipMSIE = withSession gzipApp $ do - sres1 <- doesNotEncodeGzip - [ acceptGzip - , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)") - ] + sres1 <- + doesNotEncodeGzip + [ acceptGzip + , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)") + ] assertHeader "Vary" "Accept-Encoding" sres1 caseGzipBypassPre :: Assertion @@ -393,7 +432,7 @@ -- that the compression is skipped based on the presence of -- the Content-Encoding header. withSession (gzipAppWithHeaders [(hContentEncoding, "gzip")]) $ do - sres1 <- request defaultRequest{ requestHeaders = [acceptGzip] } + sres1 <- request defaultRequest{requestHeaders = [acceptGzip]} assertHeader "Content-Encoding" "gzip" sres1 assertHeader "Vary" "Accept-Encoding" sres1 assertBody "test" sres1 -- the body is not actually compressed @@ -401,60 +440,83 @@ vhostApp1, vhostApp2, vhostApp :: Application vhostApp1 _ f = f $ responseLBS status200 [] "app1" vhostApp2 _ f = f $ responseLBS status200 [] "app2" -vhostApp = vhost - [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1) - ] - vhostApp2 +vhostApp = + vhost + [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1) + ] + vhostApp2 caseVhost :: Assertion caseVhost = withSession vhostApp $ do - sres1 <- request defaultRequest + sres1 <- + request + defaultRequest { requestHeaders = [("Host", "foo.com")] } assertBody "app1" sres1 - sres2 <- request defaultRequest + sres2 <- + request + defaultRequest { requestHeaders = [("Host", "bar.com")] } assertBody "app2" sres2 autoheadApp :: Application -autoheadApp = autohead $ \_ f -> f $ responseLBS status200 - [("Foo", "Bar")] "body" +autoheadApp = autohead $ \_ f -> + f $ + responseLBS + status200 + [("Foo", "Bar")] + "body" caseAutohead :: Assertion caseAutohead = withSession autoheadApp $ do - sres1 <- request defaultRequest + sres1 <- + request + defaultRequest { requestMethod = "GET" } assertHeader "Foo" "Bar" sres1 assertBody "body" sres1 - sres2 <- request defaultRequest + sres2 <- + request + defaultRequest { requestMethod = "HEAD" } assertHeader "Foo" "Bar" sres2 assertBody "" sres2 moApp :: Application -moApp = methodOverride $ \req f -> f $ responseLBS status200 - [("Method", requestMethod req)] "" +moApp = methodOverride $ \req f -> + f $ + responseLBS + status200 + [("Method", requestMethod req)] + "" caseMethodOverride :: Assertion caseMethodOverride = withSession moApp $ do - sres1 <- request defaultRequest + sres1 <- + request + defaultRequest { requestMethod = "GET" , queryString = [] } assertHeader "Method" "GET" sres1 - sres2 <- request defaultRequest + sres2 <- + request + defaultRequest { requestMethod = "POST" , queryString = [] } assertHeader "Method" "POST" sres2 - sres3 <- request defaultRequest + sres3 <- + request + defaultRequest { requestMethod = "POST" , queryString = [("_method", Just "PUT")] } @@ -465,46 +527,61 @@ caseMethodOverridePost :: Assertion caseMethodOverridePost = withSession mopApp $ do - -- Get Request are unmodified - sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" - s = simpleRequest r - m = s { requestMethod = "GET" } - b = r { simpleRequest = m } - in srequest b + sres1 <- + let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" + s = simpleRequest r + m = s{requestMethod = "GET"} + b = r{simpleRequest = m} + in srequest b assertHeader "Method" "GET" sres1 -- Post requests are modified if _method comes first - sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" + sres2 <- + srequest $ + toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin" assertHeader "Method" "PUT" sres2 -- Post requests are unmodified if _method doesn't come first - sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin" + sres3 <- + srequest $ + toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres3 -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded" - sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin" + sres4 <- + srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin" assertHeader "Method" "POST" sres4 aoApp :: Application -aoApp = acceptOverride $ \req f -> f $ responseLBS status200 - [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] "" +aoApp = acceptOverride $ \req f -> + f $ + responseLBS + status200 + [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] + "" caseAcceptOverride :: Assertion caseAcceptOverride = withSession aoApp $ do - sres1 <- request defaultRequest + sres1 <- + request + defaultRequest { queryString = [] , requestHeaders = [("Accept", "foo")] } assertHeader "Accept" "foo" sres1 - sres2 <- request defaultRequest + sres2 <- + request + defaultRequest { queryString = [] , requestHeaders = [("Accept", "bar")] } assertHeader "Accept" "bar" sres2 - sres3 <- request defaultRequest + sres3 <- + request + defaultRequest { queryString = [("_accept", Just "baz")] , requestHeaders = [("Accept", "bar")] } @@ -519,26 +596,35 @@ let qs = "?foo=bar&baz=bin" withSession (debugApp $ getOutput params) $ do - assertStatus 200 =<< request defaultRequest - { requestMethod = "GET" - , queryString = map (\(k,v) -> (k, Just v)) params - , rawQueryString = qs - , requestHeaders = [] - , rawPathInfo = "/location" - } + assertStatus 200 + =<< request + defaultRequest + { requestMethod = "GET" + , queryString = map (\(k, v) -> (k, Just v)) params + , rawQueryString = qs + , requestHeaders = [] + , rawPathInfo = "/location" + } where params = [("foo", "bar"), ("baz", "bin")] -- the time cannot be known, so match around it postOutput = (T.pack $ "POST /\n Params: " ++ show params, "s\n") - getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n") + getOutput params' = + ( "GET /location\n Params: " + <> T.pack (show params') + <> "\n Accept: \n Status: 200 OK 0" + , "s\n" + ) debugApp (beginning, ending) req send = do iactual <- I.newIORef mempty - middleware <- mkRequestLogger def - { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) - , outputFormat = Detailed False - } - res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send + middleware <- + mkRequestLogger + def + { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) + , outputFormat = Detailed False + } + res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send actual <- logToBs <$> I.readIORef iactual actual `shouldSatisfy` S.isPrefixOf begin actual `shouldSatisfy` S.isSuffixOf end @@ -546,72 +632,73 @@ return res where begin = TE.encodeUtf8 $ T.toStrict beginning - end = TE.encodeUtf8 $ T.toStrict ending + end = TE.encodeUtf8 $ T.toStrict ending logToBs = fromLogStr - {-debugApp = debug $ \req -> do-} - {-return $ responseLBS status200 [ ] ""-} +{-debugApp = debug $ \req -> do-} +{-return $ responseLBS status200 [ ] ""-} urlMapTestApp :: Application -urlMapTestApp = mapUrls $ - mount "bugs" bugsApp - <|> mount "helpdesk" helpdeskApp - <|> mount "api" - ( mount "v1" apiV1 - <|> mount "v2" apiV2 - ) - <|> mountRoot mainApp - +urlMapTestApp = + mapUrls $ + mount "bugs" bugsApp + <|> mount "helpdesk" helpdeskApp + <|> mount + "api" + ( mount "v1" apiV1 + <|> mount "v2" apiV2 + ) + <|> mountRoot mainApp where - trivialApp :: S.ByteString -> Application - trivialApp name req f = - f $ - responseLBS - status200 - [ ("content-type", "text/plain") - , ("X-pathInfo", S8.pack . show . pathInfo $ req) - , ("X-rawPathInfo", rawPathInfo req) - , ("X-appName", name) - ] - "" + trivialApp :: S.ByteString -> Application + trivialApp name req f = + f $ + responseLBS + status200 + [ ("content-type", "text/plain") + , ("X-pathInfo", S8.pack . show . pathInfo $ req) + , ("X-rawPathInfo", rawPathInfo req) + , ("X-appName", name) + ] + "" - bugsApp = trivialApp "bugs" - helpdeskApp = trivialApp "helpdesk" - apiV1 = trivialApp "apiv1" - apiV2 = trivialApp "apiv2" - mainApp = trivialApp "main" + bugsApp = trivialApp "bugs" + helpdeskApp = trivialApp "helpdesk" + apiV1 = trivialApp "apiv1" + apiV2 = trivialApp "apiv2" + mainApp = trivialApp "main" casesUrlMap :: [(String, Assertion)] casesUrlMap = [pair1, pair2, pair3, pair4] where - makePair name session = (name, runSession session urlMapTestApp) - get reqPath = request $ setPath defaultRequest reqPath - s = S8.pack . show :: [TS.Text] -> S.ByteString + makePair name session = (name, runSession session urlMapTestApp) + get reqPath = request $ setPath defaultRequest reqPath + s = S8.pack . show :: [TS.Text] -> S.ByteString - pair1 = makePair "should mount root" $ do - res1 <- get "/" - assertStatus 200 res1 - assertHeader "X-rawPathInfo" "/" res1 - assertHeader "X-pathInfo" (s []) res1 - assertHeader "X-appName" "main" res1 + pair1 = makePair "should mount root" $ do + res1 <- get "/" + assertStatus 200 res1 + assertHeader "X-rawPathInfo" "/" res1 + assertHeader "X-pathInfo" (s []) res1 + assertHeader "X-appName" "main" res1 - pair2 = makePair "should mount apps" $ do - res2 <- get "/bugs" - assertStatus 200 res2 - assertHeader "X-rawPathInfo" "/" res2 - assertHeader "X-pathInfo" (s []) res2 - assertHeader "X-appName" "bugs" res2 + pair2 = makePair "should mount apps" $ do + res2 <- get "/bugs" + assertStatus 200 res2 + assertHeader "X-rawPathInfo" "/" res2 + assertHeader "X-pathInfo" (s []) res2 + assertHeader "X-appName" "bugs" res2 - pair3 = makePair "should preserve extra path info" $ do - res3 <- get "/helpdesk/issues/11" - assertStatus 200 res3 - assertHeader "X-rawPathInfo" "/issues/11" res3 - assertHeader "X-pathInfo" (s ["issues", "11"]) res3 + pair3 = makePair "should preserve extra path info" $ do + res3 <- get "/helpdesk/issues/11" + assertStatus 200 res3 + assertHeader "X-rawPathInfo" "/issues/11" res3 + assertHeader "X-pathInfo" (s ["issues", "11"]) res3 - pair4 = makePair "should 404 if none match" $ do - res4 <- get "/api/v3" - assertStatus 404 res4 + pair4 = makePair "should 404 if none match" $ do + res4 <- get "/api/v3" + assertStatus 404 res4 testFile :: FilePath testFile = "test/WaiExtraSpec.hs" @@ -627,9 +714,12 @@ assertNoHeader "Transfer-Encoding" sres streamLBSApp :: Application -streamLBSApp = streamFile $ \_ f -> f $ responseLBS status200 - [("Content-Type", "text/plain")] - "test" +streamLBSApp = streamFile $ \_ f -> + f $ + responseLBS + status200 + [("Content-Type", "text/plain")] + "test" caseStreamLBS :: Assertion caseStreamLBS = withSession streamLBSApp $ do @@ -641,8 +731,9 @@ caseModifyPostParamsInLogs = do let formatUnredacted = DetailedWithSettings $ DetailedSettings False Nothing Nothing False outputUnredacted = [("username", "some_user"), ("password", "dont_show_me")] - formatRedacted = DetailedWithSettings $ DetailedSettings False (Just hidePasswords) Nothing False - hidePasswords p@(k,_) = Just $ if k == "password" then (k, "***REDACTED***") else p + formatRedacted = + DetailedWithSettings $ DetailedSettings False (Just hidePasswords) Nothing False + hidePasswords p@(k, _) = Just $ if k == "password" then (k, "***REDACTED***") else p outputRedacted = [("username", "some_user"), ("password", "***REDACTED***")] testLogs formatUnredacted outputUnredacted @@ -650,21 +741,25 @@ where testLogs :: OutputFormat -> [(String, String)] -> Assertion testLogs format output = withSession (debugApp format output) $ do - let req = toRequest "application/x-www-form-urlencoded" "username=some_user&password=dont_show_me" + let req = + toRequest + "application/x-www-form-urlencoded" + "username=some_user&password=dont_show_me" res <- srequest req assertStatus 200 res postOutputStart params = TE.encodeUtf8 $ T.toStrict $ "POST /\n Params: " <> (T.pack . show $ params) postOutputEnd = TE.encodeUtf8 $ T.toStrict "s\n" - debugApp format output req send = do iactual <- I.newIORef mempty - middleware <- mkRequestLogger def - { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) - , outputFormat = format - } - res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send + middleware <- + mkRequestLogger + def + { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) + , outputFormat = format + } + res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send actual <- fromLogStr <$> I.readIORef iactual actual `shouldSatisfy` S.isPrefixOf (postOutputStart output) actual `shouldSatisfy` S.isSuffixOf postOutputEnd @@ -674,7 +769,9 @@ caseFilterRequestsInLogs :: Assertion caseFilterRequestsInLogs = do let formatUnfiltered = DetailedWithSettings $ DetailedSettings False Nothing Nothing False - formatFiltered = DetailedWithSettings $ DetailedSettings False Nothing (Just hideHealthCheck) False + formatFiltered = + DetailedWithSettings $ + DetailedSettings False Nothing (Just hideHealthCheck) False pathHidden = "/health-check" pathNotHidden = "/foobar" @@ -696,33 +793,35 @@ debugApp format rpath haslogs req send = do iactual <- I.newIORef mempty - middleware <- mkRequestLogger def - { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) - , outputFormat = format - } - res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send + middleware <- + mkRequestLogger + def + { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) + , outputFormat = format + } + res <- middleware (\_req f -> f $ responseLBS status200 [] "") req send actual <- fromLogStr <$> I.readIORef iactual if haslogs - then do - actual `shouldSatisfy` S.isPrefixOf ("GET " <> rpath <> "\n") - actual `shouldSatisfy` S.isSuffixOf "s\n" - else - actual `shouldBe` "" + then do + actual `shouldSatisfy` S.isPrefixOf ("GET " <> rpath <> "\n") + actual `shouldSatisfy` S.isSuffixOf "s\n" + else actual `shouldBe` "" return res -- | Unit test to make sure 'parseQValueList' works correctly caseQValues :: Assertion caseQValues = do - let encodings = mconcat - -- This has weird white space on purpose, because this - -- should be acceptable according to RFC 7231 - [ "deflate, compress; q=0.813 ,gzip ; q=0.9, * ;q=0, " - , "notq;charset=bar, " - , "noq;q=, " - , "toolong;q=0.0023, " - , "toohigh ;q=1.1" - ] + let encodings = + mconcat + -- This has weird white space on purpose, because this + -- should be acceptable according to RFC 7231 + [ "deflate, compress; q=0.813 ,gzip ; q=0.9, * ;q=0, " + , "notq;charset=bar, " + , "noq;q=, " + , "toolong;q=0.0023, " + , "toohigh ;q=1.1" + ] qList = parseQValueList encodings expected = [ ("deflate", Just 1000) diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/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 @@ 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 @@ 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