diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for wai-extra +## 3.1.13.0 + +* Added `Combine Headers` `Middleware` [#901](https://github.com/yesodweb/wai/pull/901) + ## 3.1.12.1 * Include test/{json.gz,noprecompress} as extra-source-files [#887](https://github.com/yesodweb/wai/pull/887) diff --git a/Network/Wai/Header.hs b/Network/Wai/Header.hs --- a/Network/Wai/Header.hs +++ b/Network/Wai/Header.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE CPP #-} -- | Some helpers for dealing with WAI 'Header's. module Network.Wai.Header ( contentLength , parseQValueList , replaceHeader - , splitCommas - , trimWS ) where import Control.Monad (guard) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Internal (w2c) -import Data.Word8 (Word8, _0, _1, _comma, _period, _semicolon, _space) +import Data.Word8 (_0, _1, _period, _semicolon, _space) import Network.HTTP.Types as H import Text.Read (readMaybe) +import Network.Wai.Util (dropWhileEnd, splitCommas) + -- | More useful for a response. A Wai Request already has a requestBodyLength contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer contentLength hdrs = lookup H.hContentLength hdrs >>= readInt @@ -30,22 +29,6 @@ replaceHeader :: H.HeaderName -> S.ByteString -> [H.Header] -> [H.Header] replaceHeader name val old = (name, val) : filter ((/= name) . fst) old - --- | Used to split a header value which is a comma separated list -splitCommas :: S.ByteString -> [S.ByteString] -splitCommas = map trimWS . S.split _comma - --- Trim whitespace -trimWS :: S.ByteString -> S.ByteString -trimWS = dropWhileEnd (== _space) . S.dropWhile (== _space) - --- | Dropping all 'Word8's from the end that satisfy the predicate. -dropWhileEnd :: (Word8 -> Bool) -> S.ByteString -> S.ByteString -#if MIN_VERSION_bytestring(0,10,12) -dropWhileEnd = S.dropWhileEnd -#else -dropWhileEnd p = fst . S.spanEnd p -#endif -- | Only to be used on header's values which support quality value syntax -- diff --git a/Network/Wai/Middleware/CombineHeaders.hs b/Network/Wai/Middleware/CombineHeaders.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/CombineHeaders.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Sometimes incoming requests don't stick to the +"no duplicate headers" invariant, for a number +of possible reasons (e.g. proxy servers blindly +adding headers), or your application (or other +middleware) blindly adds headers. + +In those cases, you can use this 'Middleware' +to make sure that headers that /can/ be combined +/are/ combined. (e.g. applications might only +check the first \"Accept\" header and fail, while +there might be another one that would match) + -} +module Network.Wai.Middleware.CombineHeaders + ( combineHeaders + , CombineSettings + , defaultCombineSettings + , HeaderMap + , HandleType + , defaultHeaderMap + -- * Adjusting the settings + , setHeader + , removeHeader + , setHeaderMap + , regular + , keepOnly + , setRequestHeaders + , setResponseHeaders + ) where + +import qualified Data.ByteString as B +import qualified Data.List as L (foldl', reverse) +import qualified Data.Map.Strict as M +import Data.Word8 (_comma, _space, _tab) +import Network.HTTP.Types (Header, HeaderName, RequestHeaders) +import qualified Network.HTTP.Types.Header as H +import Network.Wai (Middleware, requestHeaders, mapResponseHeaders) +import Network.Wai.Util (dropWhileEnd) + +-- | The mapping of 'HeaderName' to 'HandleType' +type HeaderMap = M.Map HeaderName HandleType + +-- | These settings define which headers should be combined, +-- if the combining should happen on incoming (request) headers +-- and if it should happen on outgoing (response) headers. +-- +-- Any header you put in the header map *will* be used to +-- combine those headers with commas. There's no check to see +-- if it is a header that allows comma-separated lists, so if +-- you want to combine custom headers, go ahead. +-- +-- (You can check the documentation of 'defaultCombineSettings' +-- to see which standard headers are specified to be able to be +-- combined) +-- +-- @since 3.1.13.0 +data CombineSettings = CombineSettings { + combineHeaderMap :: HeaderMap, + -- ^ Which headers should be combined? And how? (cf. 'HandleType') + combineRequestHeaders :: Bool, + -- ^ Should request headers be combined? + combineResponseHeaders :: Bool + -- ^ Should response headers be combined? +} deriving (Eq, Show) + +-- | Settings that combine request headers, +-- but don't touch response headers. +-- +-- All types of headers that /can/ be combined +-- (as defined in the spec) /will/ be combined. +-- +-- To be exact, this is the list: +-- +-- * Accept +-- * Accept-CH +-- * Accept-Charset +-- * Accept-Encoding +-- * Accept-Language +-- * Accept-Post +-- * Access-Control-Allow-Headers +-- * Access-Control-Allow-Methods +-- * Access-Control-Expose-Headers +-- * Access-Control-Request-Headers +-- * Allow +-- * Alt-Svc @(KeepOnly \"clear\"")@ +-- * Cache-Control +-- * Clear-Site-Data @(KeepOnly \"*\")@ +-- * Connection +-- * Content-Encoding +-- * Content-Language +-- * Digest +-- * If-Match +-- * If-None-Match @(KeepOnly \"*\")@ +-- * Link +-- * Permissions-Policy +-- * TE +-- * Timing-Allow-Origin @(KeepOnly \"*\")@ +-- * Trailer +-- * Transfer-Encoding +-- * Upgrade +-- * Via +-- * Vary @(KeepOnly \"*\")@ +-- * Want-Digest +-- +-- N.B. Any header name that has \"KeepOnly\" after it +-- will be combined like normal, unless one of the values +-- is the one mentioned (\"*\" most of the time), then +-- that value is used and all others are dropped. +-- +-- @since 3.1.13.0 +defaultCombineSettings :: CombineSettings +defaultCombineSettings = CombineSettings { + combineHeaderMap = defaultHeaderMap, + combineRequestHeaders = True, + combineResponseHeaders = False +} + +-- | Override the 'HeaderMap' of the 'CombineSettings' +-- (default: 'defaultHeaderMap') +-- +-- @since 3.1.13.0 +setHeaderMap :: HeaderMap -> CombineSettings -> CombineSettings +setHeaderMap mp set = set{combineHeaderMap = mp} + +-- | Set whether the combining of headers should be applied to +-- the incoming request headers. (default: True) +-- +-- @since 3.1.13.0 +setRequestHeaders :: Bool -> CombineSettings -> CombineSettings +setRequestHeaders b set = set{combineRequestHeaders = b} + +-- | Set whether the combining of headers should be applied to +-- the outgoing response headers. (default: False) +-- +-- @since 3.1.13.0 +setResponseHeaders :: Bool -> CombineSettings -> CombineSettings +setResponseHeaders b set = set{combineResponseHeaders = b} + +-- | Convenience function to add a header to the header map or, +-- if it is already in the map, to change the 'HandleType'. +-- +-- @since 3.1.13.0 +setHeader :: HeaderName -> HandleType -> CombineSettings -> CombineSettings +setHeader name typ settings = + settings { + combineHeaderMap = M.insert name typ $ combineHeaderMap settings + } + +-- | Convenience function to remove a header from the header map. +-- +-- @since 3.1.13.0 +removeHeader :: HeaderName -> CombineSettings -> CombineSettings +removeHeader name settings = + settings { + combineHeaderMap = M.delete name $ combineHeaderMap settings + } + +-- | This middleware will reorganize the incoming and/or outgoing +-- headers in such a way that it combines any duplicates of +-- headers that, on their own, can normally have more than one +-- value, and any other headers will stay untouched. +-- +-- This middleware WILL change the global order of headers +-- (they will be put in alphabetical order), but keep the +-- order of the same type of header. I.e. if there are 3 +-- \"Set-Cookie\" headers, the first one will still be first, +-- the second one will still be second, etc. But now they are +-- guaranteed to be next to each other. +-- +-- N.B. This 'Middleware' assumes the headers it combines +-- are correctly formatted. If one of the to-be-combined +-- headers is malformed, the new combined header will also +-- (probably) be malformed. +-- +-- @since 3.1.13.0 +combineHeaders :: CombineSettings -> Middleware +combineHeaders CombineSettings{..} app req resFunc = + app newReq $ resFunc . adjustRes + where + newReq + | combineRequestHeaders = req { requestHeaders = mkNewHeaders oldHeaders } + | otherwise = req + oldHeaders = requestHeaders req + adjustRes + | combineResponseHeaders = mapResponseHeaders mkNewHeaders + | otherwise = id + mkNewHeaders = + M.foldrWithKey' finishHeaders [] . L.foldl' go mempty + go acc hdr@(name, _) = + M.alter (checkHeader hdr) name acc + checkHeader :: Header -> Maybe HeaderHandling -> Maybe HeaderHandling + checkHeader (name, newVal) = Just . \case + Nothing -> (name `M.lookup` combineHeaderMap, [newVal]) + -- Yes, this reverses the order of headers, but these + -- will be reversed again in 'finishHeaders' + Just (mHandleType, hdrs) -> (mHandleType, newVal : hdrs) + +-- | Unpack 'HeaderHandling' back into 'Header's again +finishHeaders :: HeaderName -> HeaderHandling -> RequestHeaders -> RequestHeaders +finishHeaders name (shouldCombine, xs) hdrs = + case shouldCombine of + Just typ -> (name, combinedHeader typ) : hdrs + Nothing -> + -- Yes, this reverses the headers, but they + -- were already reversed by 'checkHeader' + L.foldl' (\acc el -> (name, el) : acc) hdrs xs + where + combinedHeader Regular = combineHdrs xs + combinedHeader (KeepOnly val) + | val `elem` xs = val + | otherwise = combineHdrs xs + -- headers were reversed, so do 'reverse' before combining + combineHdrs = B.intercalate ", " . fmap clean . L.reverse + clean = dropWhileEnd $ \w -> w == _comma || w == _space || w == _tab + +type HeaderHandling = (Maybe HandleType, [B.ByteString]) + +-- | Both will concatenate with @,@ (commas), but 'KeepOnly' will drop all +-- values except the given one if present (e.g. in case of wildcards/special values) +-- +-- For example: If there are multiple @"Clear-Site-Data"@ headers, but one of +-- them is the wildcard @\"*\"@ value, using @'KeepOnly' "*"@ will cause all +-- others to be dropped and only the wildcard value to remain. +-- (The @\"*\"@ wildcard in this case means /ALL site data/ should be cleared, +-- so no need to include more) +-- +-- @since 3.1.13.0 +data HandleType + = Regular + | KeepOnly B.ByteString + deriving (Eq, Show) + +-- | Use the regular strategy when combining headers. +-- (i.e. merge into one header and separate values with commas) +-- +-- @since 3.1.13.0 +regular :: HandleType +regular = Regular + +-- | Use the regular strategy when combining headers, +-- but if the exact supplied 'ByteString' is encountered +-- then discard all other values and only keep that value. +-- +-- e.g. @keepOnly "*"@ will drop all other encountered values +-- +-- @since 3.1.13.0 +keepOnly :: B.ByteString -> HandleType +keepOnly = KeepOnly + +-- | The default collection of HTTP headers that can be combined +-- in case there are multiples in one request or response. +-- +-- See the documentation of 'defaultCombineSettings' for the exact list. +-- +-- @since 3.1.13.0 +defaultHeaderMap :: HeaderMap +defaultHeaderMap = M.fromList + [ (H.hAccept, Regular) + , ("Accept-CH", Regular) + , (H.hAcceptCharset, Regular) + , (H.hAcceptEncoding, Regular) + , (H.hAcceptLanguage, Regular) + , ("Accept-Post", Regular) + , ("Access-Control-Allow-Headers" , Regular) -- wildcard? yes, but can just add to list + , ("Access-Control-Allow-Methods" , Regular) -- wildcard? yes, but can just add to list + , ("Access-Control-Expose-Headers" , Regular) -- wildcard? yes, but can just add to list + , ("Access-Control-Request-Headers", Regular) + , (H.hAllow, Regular) + , ("Alt-Svc", KeepOnly "clear") -- special "clear" value (if any is "clear", only keep that one) + , (H.hCacheControl, Regular) + , ("Clear-Site-Data", KeepOnly "*") -- wildcard (if any is "*", only keep that one) + + -- If "close" and anything else is used together, it's already F-ed, + -- so just combine them. + , (H.hConnection, Regular) + + , (H.hContentEncoding, Regular) + , (H.hContentLanguage, Regular) + , ("Digest", Regular) + + -- We could handle this, but it's experimental AND + -- will be replaced by "Permissions-Policy" + -- , "Feature-Policy" -- "semicolon ';' separated" + + , (H.hIfMatch, Regular) + , (H.hIfNoneMatch, KeepOnly "*") -- wildcard? (if any is "*", only keep that one) + , ("Link", Regular) + , ("Permissions-Policy", Regular) + , (H.hTE, Regular) + , ("Timing-Allow-Origin", KeepOnly "*") -- wildcard? (if any is "*", only keep that one) + , (H.hTrailer, Regular) + , (H.hTransferEncoding, Regular) + , (H.hUpgrade, Regular) + , (H.hVia, Regular) + , (H.hVary, KeepOnly "*") -- wildcard? (if any is "*", only keep that one) + , ("Want-Digest", Regular) + ] diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -63,7 +63,8 @@ import System.Directory (createDirectoryIfMissing, doesFileExist) import qualified System.IO as IO -import Network.Wai.Header (contentLength, parseQValueList, replaceHeader, splitCommas, trimWS) +import Network.Wai.Header (contentLength, parseQValueList, replaceHeader) +import Network.Wai.Util (splitCommas, trimWS) -- $howto -- diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should -- not use CPP. +-- EDIT: Fixed this by adding two "zero-width spaces" in between the "*/*" module Network.Wai.Middleware.RequestLogger ( -- * Basic stdout logging logStdout @@ -38,7 +40,9 @@ import Data.Default.Class (Default (def)) import Data.IORef import Data.Maybe (fromMaybe, isJust, mapMaybe) -import Data.Monoid (mconcat, (<>)) +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif import Data.Text.Encoding (decodeUtf8') import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import Network.HTTP.Types as H @@ -321,15 +325,17 @@ -- Example ouput: -- -- > GET search --- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 +-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*​/​*;q=0.8 -- > Status: 200 OK 0.010555s -- > -- > GET static/css/normalize.css -- > Params: [("LXwioiBG","")] --- > Accept: text/css,*/*;q=0.1 +-- > Accept: text/css,*​/​*;q=0.1 -- > Status: 304 Not Modified 0.010555s - detailedMiddleware :: Callback -> DetailedSettings -> IO Middleware + +-- NB: The *​/​* in the comments above have "zero-width spaces" in them, so the +-- CPP doesn't screw up everything. So don't copy those; they're technically wrong. detailedMiddleware cb settings = let (ansiColor, ansiMethod, ansiStatusCode) = if useColors settings diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -70,14 +70,10 @@ import Network.HTTP.Types (hContentType) import qualified Network.HTTP.Types as H import Network.Wai +import Network.Wai.Handler.Warp (InvalidRequest(..)) import System.Directory (getTemporaryDirectory, removeFile) import System.IO (hClose, openBinaryTempFile) import System.IO.Error (isDoesNotExistError) -#if MIN_VERSION_http2(3,0,0) -import Network.HTTP2.Frame (ErrorCodeId (..), HTTP2Error (..)) -#else -import Network.HTTP2 (ErrorCodeId (..), HTTP2Error (..)) -#endif breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = @@ -444,8 +440,7 @@ bs <- readSource src case maxlen of Just maxlen' -> when (S.length front > maxlen') $ - E.throwIO $ ConnectionError (UnknownErrorCode 431) - "Request Header Fields Too Large" + E.throwIO RequestHeaderFieldsTooLarge Nothing -> return () if S.null bs then close front @@ -461,8 +456,7 @@ let res = front `S.append` x case maxlen of Just maxlen' -> when (S.length res > maxlen') $ - E.throwIO $ ConnectionError (UnknownErrorCode 431) - "Request Header Fields Too Large" + E.throwIO RequestHeaderFieldsTooLarge Nothing -> return () return . Just $ killCR res @@ -651,8 +645,7 @@ cur <- atomicModifyIORef' sref $ \ cur -> let new = cur + fromIntegral (S.length bs) in (new, new) case max' of - Just max'' | cur > max'' -> - E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large" + Just max'' | cur > max'' -> E.throwIO PayloadTooLarge _ -> return () if S.null bs then do diff --git a/Network/Wai/Util.hs b/Network/Wai/Util.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Util.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +-- | Some helpers functions. +module Network.Wai.Util + ( dropWhileEnd + , splitCommas + , trimWS + ) where + +import qualified Data.ByteString as S +import Data.Word8 (Word8, _comma, _space) + +-- | Used to split a header value which is a comma separated list +splitCommas :: S.ByteString -> [S.ByteString] +splitCommas = map trimWS . S.split _comma + +-- Trim whitespace +trimWS :: S.ByteString -> S.ByteString +trimWS = dropWhileEnd (== _space) . S.dropWhile (== _space) + +-- | Dropping all 'Word8's from the end that satisfy the predicate. +dropWhileEnd :: (Word8 -> Bool) -> S.ByteString -> S.ByteString +#if MIN_VERSION_bytestring(0,10,12) +dropWhileEnd = S.dropWhileEnd +#else +dropWhileEnd p = fst . S.spanEnd p +#endif diff --git a/test/Network/Wai/Middleware/CombineHeadersSpec.hs b/test/Network/Wai/Middleware/CombineHeadersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/CombineHeadersSpec.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.CombineHeadersSpec + ( main + , spec + ) where + +import Data.ByteString (ByteString) +import Data.IORef (newIORef, readIORef, writeIORef) +import Network.HTTP.Types (status200) +import Network.HTTP.Types.Header +import Network.Wai +import Test.Hspec + +import Network.Wai.Middleware.CombineHeaders (CombineSettings, combineHeaders, defaultCombineSettings, setRequestHeaders, setResponseHeaders) +import Network.Wai.Test (SResponse (simpleHeaders), request, runSession) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + let test name settings reqHeaders expectedReqHeaders resHeaders expectedResHeaders = it name $ do + (reqHdrs, resHdrs) <- runApp settings reqHeaders resHeaders + reqHdrs `shouldBe` expectedReqHeaders + resHdrs `shouldBe` expectedResHeaders + testReqHdrs name a b = + test name defaultCombineSettings a b [] [] + testResHdrs name a b = + test name (setRequestHeaders False $ setResponseHeaders True defaultCombineSettings) [] [] a b + + -- Request Headers + testReqHdrs + "should reorder alphabetically (request)" + [host , userAgent, acceptHtml] + [acceptHtml, host , userAgent ] + -- Response Headers + testResHdrs + "should reorder alphabetically (response)" + [expires , location, contentTypeHtml] + [contentTypeHtml, expires , location ] + + -- Request Headers + testReqHdrs + "combines Accept (in order)" + [userAgent, acceptHtml, host, acceptJSON] + [acceptHtml `combineHdrs` acceptJSON, host, userAgent] + -- Response Headers + testResHdrs + -- Using the default header map, Cache-Control is a "combineable" header, "Set-Cookie" is not + "combines Cache-Control (in order) and keeps Set-Cookie (in order)" + [ cacheControlPublic, setCookie "2", date, cacheControlMax, setCookie "1"] + [ cacheControlPublic `combineHdrs` cacheControlMax, date, setCookie "2", setCookie "1"] + + -- Request Headers + testReqHdrs + "KeepOnly works as expected (present | request)" + -- "Alt-Svc" has (KeepOnly "clear") + [ date, altSvc "wrong", altSvc "clear", altSvc "wrong again", host ] + [ altSvc "clear", date, host ] + testReqHdrs + "KeepOnly works as expected ( absent | request)" + -- "Alt-Svc" has (KeepOnly "clear"), but will combine when there's no "clear" (AND keeps order) + [ date, altSvc "wrong", altSvc "not clear", altSvc "wrong again", host ] + [ altSvc "wrong, not clear, wrong again", date, host ] + + -- Response Headers + testResHdrs + "KeepOnly works as expected (present | response)" + -- "If-None-Match" has (KeepOnly "*") + [ date, ifNoneMatch "wrong", ifNoneMatch "*", ifNoneMatch "wrong again", host ] + [ date, host, ifNoneMatch "*" ] + testResHdrs + "KeepOnly works as expected ( absent | response)" + -- "If-None-Match" has (KeepOnly "*"), but will combine when there's no "*" (AND keeps order) + [ date, ifNoneMatch "wrong", ifNoneMatch "not *", ifNoneMatch "wrong again", host ] + [ date, host, ifNoneMatch "wrong, not *, wrong again" ] + + -- Request Headers + testReqHdrs + "Technically acceptable headers get combined correctly (request)" + [ ifNoneMatch "correct, ", ifNoneMatch "something else \t", ifNoneMatch "and more , "] + [ ifNoneMatch "correct, something else, and more" ] + -- Response Headers + testResHdrs + "Technically acceptable headers get combined correctly (response)" + [ altSvc "correct\t, ", altSvc "something else", altSvc "and more, , "] + [ altSvc "correct, something else, and more" ] + +combineHdrs :: Header -> Header -> Header +combineHdrs (hname, h1) (_, h2) = (hname, h1 <> ", " <> h2) + +acceptHtml, + acceptJSON, + cacheControlMax, + cacheControlPublic, + contentTypeHtml, + date, + expires, + host, + location, + userAgent :: Header + +acceptHtml = (hAccept, "text/html") +acceptJSON = (hAccept, "application/json") +altSvc :: ByteString -> Header +altSvc x = ("Alt-Svc", x) +cacheControlPublic = (hCacheControl, "public") +cacheControlMax = (hCacheControl, "public") +contentTypeHtml = (hContentType, "text/html") +date = (hDate, "Mon, 19 Aug 2022 18:18:31 GMT") +expires = (hExpires, "Mon, 19 Sep 2022 18:18:31 GMT") +host = (hHost, "google.com") +ifNoneMatch :: ByteString -> Header +ifNoneMatch x = (hIfNoneMatch, x) +location = (hLocation, "http://www.google.com/") +setCookie :: ByteString -> Header +setCookie val = (hSetCookie, val) +userAgent = (hUserAgent, "curl/7.68.0") + +runApp :: CombineSettings -> RequestHeaders -> ResponseHeaders -> IO (RequestHeaders, ResponseHeaders) +runApp settings reqHeaders resHeaders = do + reqHdrs <- newIORef $ error "IORef not set" + sResponse <- runSession + session + $ combineHeaders settings $ app reqHdrs + finalReqHeaders <- readIORef reqHdrs + pure (finalReqHeaders, simpleHeaders sResponse) + where + session = + request + defaultRequest { requestHeaders = reqHeaders } + app hdrRef req respond = do + writeIORef hdrRef $ requestHeaders req + respond $ responseLBS status200 resHeaders "" diff --git a/test/Network/Wai/ParseSpec.hs b/test/Network/Wai/ParseSpec.hs --- a/test/Network/Wai/ParseSpec.hs +++ b/test/Network/Wai/ParseSpec.hs @@ -12,12 +12,8 @@ import qualified Data.IORef as I import qualified Data.Text as TS import qualified Data.Text.Encoding as TE -#if MIN_VERSION_http2(3,0,0) -import Network.HTTP2.Frame (ErrorCodeId (..), HTTP2Error (..)) -#else -import Network.HTTP2 (ErrorCodeId (..), HTTP2Error (..)) -#endif import Network.Wai (Request (requestBody, requestHeaders), defaultRequest) +import Network.Wai.Handler.Warp (InvalidRequest(..)) import System.IO (IOMode (ReadMode), withFile) import Test.HUnit (Assertion, (@=?), (@?=)) import Test.Hspec @@ -101,10 +97,6 @@ let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")] let expected3 = (expectedsmap3, expectedfile3) - let unknownErrorException c (ConnectionError (UnknownErrorCode code) _) = c == code - unknownErrorException _ _ = False - - let def = defaultParseRequestBodyOptions it "parsing actual post multipart/form-data" $ do result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3 @@ -130,20 +122,20 @@ it "exceeding file size" $ do SRequest req4 _bod4 <- toRequest'' ctype3 content3 (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4) - `shouldThrow` unknownErrorException 413 + `shouldThrow` (== PayloadTooLarge) it "exceeding total file size" $ do SRequest req4 _bod4 <- toRequest'' ctype3 content3 (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4) - `shouldThrow` unknownErrorException 413 + `shouldThrow` (== PayloadTooLarge) SRequest req5 _bod5 <- toRequest'' ctype3 content5 (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5) - `shouldThrow` unknownErrorException 413 + `shouldThrow` (== PayloadTooLarge) it "exceeding max parm value size" $ do SRequest req4 _bod4 <- toRequest'' ctype2 content2 (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4) - `shouldThrow` unknownErrorException 413 + `shouldThrow` (== PayloadTooLarge) it "exceeding max header lines" $ do SRequest req4 _bod4 <- toRequest'' ctype2 content2 @@ -152,7 +144,7 @@ it "exceeding header line size" $ do SRequest req4 _bod4 <- toRequest'' ctype3 content4 (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4) - `shouldThrow` unknownErrorException 431 + `shouldThrow` (== RequestHeaderFieldsTooLarge) it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou" 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.12.1 +Version: 3.1.13.0 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: @@ -27,6 +27,10 @@ . Clean a request path to a canonical form. . + * Combine Headers + . + Combine duplicate headers into one. + . * GZip Compression . Negotiate HTTP payload gzip compression. @@ -98,31 +102,31 @@ Library Build-Depends: base >= 4.12 && < 5 + , aeson + , ansi-terminal + , base64-bytestring , bytestring >= 0.10.4 - , wai >= 3.0.3.0 && < 3.3 - , time >= 1.1.4 - , network >= 2.6.1.0 - , directory >= 1.2.7.0 - , transformers >= 0.2.2 - , http-types >= 0.7 - , text >= 0.7 + , call-stack , case-insensitive >= 0.2 + , containers + , cookie , data-default-class + , directory >= 1.2.7.0 , fast-logger >= 2.4.5 - , wai-logger >= 2.3.7 - , ansi-terminal - , resourcet >= 0.4.6 && < 1.3 - , containers - , base64-bytestring - , word8 + , http-types >= 0.7 + , HUnit + , iproute >= 1.7.8 + , network >= 2.6.1.0 + , resourcet >= 0.4.6 && < 1.4 , streaming-commons >= 0.2 - , cookie + , text >= 0.7 + , time >= 1.1.4 + , transformers >= 0.2.2 , vault - , aeson - , iproute >= 1.7.8 - , http2 - , HUnit - , call-stack + , wai >= 3.0.3.0 && < 3.3 + , wai-logger >= 2.3.7 + , warp >= 3.3.22 + , word8 if os(windows) cpp-options: -DWINDOWS @@ -131,7 +135,9 @@ default-extensions: OverloadedStrings - Exposed-modules: Network.Wai.Handler.CGI + Exposed-modules: Network.Wai.EventSource + Network.Wai.EventSource.EventStream + Network.Wai.Handler.CGI Network.Wai.Handler.SCGI Network.Wai.Header Network.Wai.Middleware.AcceptOverride @@ -139,35 +145,35 @@ Network.Wai.Middleware.Approot Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath - Network.Wai.Middleware.HealthCheckEndpoint - Network.Wai.Middleware.Local - Network.Wai.Middleware.RequestLogger - Network.Wai.Middleware.RequestLogger.JSON - Network.Wai.Middleware.Select + Network.Wai.Middleware.CombineHeaders + Network.Wai.Middleware.ForceDomain + Network.Wai.Middleware.ForceSSL Network.Wai.Middleware.Gzip + Network.Wai.Middleware.HealthCheckEndpoint + Network.Wai.Middleware.HttpAuth Network.Wai.Middleware.Jsonp + Network.Wai.Middleware.Local Network.Wai.Middleware.MethodOverride Network.Wai.Middleware.MethodOverridePost + Network.Wai.Middleware.RealIp + Network.Wai.Middleware.RequestLogger + Network.Wai.Middleware.RequestLogger.JSON + Network.Wai.Middleware.RequestSizeLimit + Network.Wai.Middleware.RequestSizeLimit.Internal Network.Wai.Middleware.Rewrite - Network.Wai.Middleware.StripHeaders - Network.Wai.Middleware.Vhost - Network.Wai.Middleware.HttpAuth - Network.Wai.Middleware.StreamFile - Network.Wai.Middleware.ForceDomain - Network.Wai.Middleware.ForceSSL Network.Wai.Middleware.Routed + Network.Wai.Middleware.Select + Network.Wai.Middleware.StreamFile + Network.Wai.Middleware.StripHeaders Network.Wai.Middleware.Timeout - Network.Wai.Middleware.RealIp + Network.Wai.Middleware.Vhost Network.Wai.Parse Network.Wai.Request - Network.Wai.UrlMap Network.Wai.Test Network.Wai.Test.Internal - Network.Wai.EventSource - Network.Wai.EventSource.EventStream - Network.Wai.Middleware.RequestSizeLimit - Network.Wai.Middleware.RequestSizeLimit.Internal + Network.Wai.UrlMap other-modules: Network.Wai.Middleware.RequestLogger.Internal + Network.Wai.Util default-language: Haskell2010 ghc-options: -Wall @@ -177,12 +183,12 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall if flag(build-example) build-depends: base + , bytestring + , http-types + , time + , wai , wai-extra , warp - , wai - , time - , http-types - , bytestring else buildable: False default-language: Haskell2010 @@ -191,10 +197,8 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: Network.Wai.TestSpec - Network.Wai.ParseSpec - Network.Wai.RequestSpec - Network.Wai.Middleware.ApprootSpec + other-modules: Network.Wai.Middleware.ApprootSpec + Network.Wai.Middleware.CombineHeadersSpec Network.Wai.Middleware.ForceSSLSpec Network.Wai.Middleware.RealIpSpec Network.Wai.Middleware.RequestSizeLimitSpec @@ -202,27 +206,30 @@ Network.Wai.Middleware.SelectSpec Network.Wai.Middleware.StripHeadersSpec Network.Wai.Middleware.TimeoutSpec + Network.Wai.ParseSpec + Network.Wai.RequestSpec + Network.Wai.TestSpec WaiExtraSpec + build-tool-depends: hspec-discover:hspec-discover build-depends: base >= 4 && < 5 - , wai-extra - , wai - , hspec >= 1.3 - , transformers - , fast-logger - , http-types - , zlib - , text - , resourcet + , aeson , bytestring - , HUnit , cookie - , time , case-insensitive - , http2 - , aeson + , directory + , fast-logger + , hspec >= 1.3 + , http-types + , HUnit , iproute + , resourcet , temporary - , directory + , text + , time + , wai-extra + , wai + , warp + , zlib ghc-options: -Wall default-language: Haskell2010