wai-extra 3.1.14 → 3.1.15
raw patch · 9 files changed
+920/−531 lines, 9 files
Files
- ChangeLog.md +5/−4
- Network/Wai/Handler/CGI.hs +75/−60
- Network/Wai/Middleware/Local.hs +12/−12
- Network/Wai/Middleware/ValidateHeaders.hs +138/−0
- Network/Wai/Parse.hs +311/−238
- test/Network/Wai/Middleware/ValidateHeadersSpec.hs +59/−0
- test/Network/Wai/TestSpec.hs +19/−17
- test/WaiExtraSpec.hs +298/−199
- wai-extra.cabal +3/−1
ChangeLog.md view
@@ -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
Network/Wai/Handler/CGI.hs view
@@ -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
Network/Wai/Middleware/Local.hs view
@@ -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)
+ Network/Wai/Middleware/ValidateHeaders.hs view
@@ -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
Network/Wai/Parse.hs view
@@ -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)
+ test/Network/Wai/Middleware/ValidateHeadersSpec.hs view
@@ -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 ""
test/Network/Wai/TestSpec.hs view
@@ -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
test/WaiExtraSpec.hs view
@@ -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)
wai-extra.cabal view
@@ -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