diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for http-client +## 0.7.18 + +* Add the `managerSetMaxNumberHeaders` function to the `Client` module to configure `managerMaxNumberHeaders` in `ManagerSettings`. + ## 0.7.17 * Add `managerSetMaxHeaderLength` to `Client` to change `ManagerSettings` `MaxHeaderLength`. diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -113,6 +113,7 @@ , managerSetInsecureProxy , managerSetSecureProxy , managerSetMaxHeaderLength + , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy @@ -325,6 +326,11 @@ managerSetMaxHeaderLength :: Int -> ManagerSettings -> ManagerSettings managerSetMaxHeaderLength l manager = manager { managerMaxHeaderLength = Just $ MaxHeaderLength l } + +-- @since 0.7.18 +managerSetMaxNumberHeaders :: Int -> ManagerSettings -> ManagerSettings +managerSetMaxNumberHeaders n manager = manager + { managerMaxNumberHeaders = Just $ MaxNumberHeaders n } -- $example1 -- = Example Usage diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs --- a/Network/HTTP/Client/Core.hs +++ b/Network/HTTP/Client/Core.hs @@ -105,7 +105,7 @@ ex <- try $ do cont <- requestBuilder (dropProxyAuthSecure req) (managedResource mconn) - getResponse (mMaxHeaderLength m) timeout' req mconn cont + getResponse (mMaxHeaderLength m) (mMaxNumberHeaders m) timeout' req mconn cont case ex of -- Connection was reused, and might have been closed. Try again diff --git a/Network/HTTP/Client/Headers.hs b/Network/HTTP/Client/Headers.hs --- a/Network/HTTP/Client/Headers.hs +++ b/Network/HTTP/Client/Headers.hs @@ -28,8 +28,8 @@ charPeriod = 46 -parseStatusHeaders :: Maybe MaxHeaderLength -> Connection -> Maybe Int -> ([Header] -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders -parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont +parseStatusHeaders :: Maybe MaxHeaderLength -> Maybe MaxNumberHeaders -> Connection -> Maybe Int -> ([Header] -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders +parseStatusHeaders mhl mnh conn timeout' onEarlyHintHeaders cont | Just k <- cont = getStatusExpectContinue k | otherwise = getStatus where @@ -91,9 +91,14 @@ Just (i, "") -> Just i _ -> Nothing + guardMaxNumberHeaders :: Int -> IO () + guardMaxNumberHeaders count = case fmap unMaxNumberHeaders mnh of + Nothing -> pure () + Just n -> when (count >= n) $ throwHttp TooManyHeaderFields + parseHeaders :: Int -> ([Header] -> [Header]) -> IO [Header] - parseHeaders 100 _ = throwHttp OverlongHeaders parseHeaders count front = do + guardMaxNumberHeaders count line <- connectionReadLine mhl conn if S.null line then return $ front [] @@ -107,8 +112,8 @@ parseHeaders count front parseEarlyHintHeadersUntilFailure :: Int -> ([Header] -> [Header]) -> IO [Header] - parseEarlyHintHeadersUntilFailure 100 _ = throwHttp OverlongHeaders parseEarlyHintHeadersUntilFailure count front = do + guardMaxNumberHeaders count line <- connectionReadLine mhl conn if S.null line then return $ front [] diff --git a/Network/HTTP/Client/Manager.hs b/Network/HTTP/Client/Manager.hs --- a/Network/HTTP/Client/Manager.hs +++ b/Network/HTTP/Client/Manager.hs @@ -93,6 +93,7 @@ , managerProxyInsecure = defaultProxy , managerProxySecure = defaultProxy , managerMaxHeaderLength = Just $ MaxHeaderLength 4096 + , managerMaxNumberHeaders = Just $ MaxNumberHeaders 100 } -- | Create a 'Manager'. The @Manager@ will be shut down automatically via @@ -133,6 +134,7 @@ then httpsProxy req else httpProxy req , mMaxHeaderLength = managerMaxHeaderLength ms + , mMaxNumberHeaders = managerMaxNumberHeaders ms } return manager @@ -259,7 +261,9 @@ , "\r\n" ] parse conn = do - StatusHeaders status _ _ _ <- parseStatusHeaders (managerMaxHeaderLength ms) conn Nothing (\_ -> return ()) Nothing + let mhl = managerMaxHeaderLength ms + mnh = managerMaxNumberHeaders ms + StatusHeaders status _ _ _ <- parseStatusHeaders mhl mnh conn Nothing (\_ -> return ()) Nothing unless (status == status200) $ throwHttp $ ProxyConnectException ultHost ultPort status in tlsProxyConnection diff --git a/Network/HTTP/Client/Response.hs b/Network/HTTP/Client/Response.hs --- a/Network/HTTP/Client/Response.hs +++ b/Network/HTTP/Client/Response.hs @@ -81,10 +81,10 @@ mergeHeaders :: W.RequestHeaders -> W.RequestHeaders -> W.RequestHeaders mergeHeaders lhs rhs = nubBy (\(a, _) (a', _) -> a == a') (lhs ++ rhs) - + stripHeaders :: Request -> Request stripHeaders r = do - case (hostDiffer r, shouldStripOnlyIfHostDiffer) of + case (hostDiffer r, shouldStripOnlyIfHostDiffer) of (True, True) -> stripHeaders' r (True, False) -> stripHeaders' r (False, False) -> stripHeaders' r @@ -92,7 +92,7 @@ -- We need to check if we have omitted headers in previous -- request chain. Consider request chain: -- - -- 1. example-1.com + -- 1. example-1.com -- 2. example-2.com (we may have removed some headers here from 1) -- 3. example-1.com (since we are back at same host as 1, we need re-add stripped headers) -- @@ -114,14 +114,15 @@ } getResponse :: Maybe MaxHeaderLength + -> Maybe MaxNumberHeaders -> Maybe Int -> Request -> Managed Connection -> Maybe (IO ()) -- ^ Action to run in case of a '100 Continue'. -> IO (Response BodyReader) -getResponse mhl timeout' req@(Request {..}) mconn cont = do +getResponse mhl mnh timeout' req@(Request {..}) mconn cont = do let conn = managedResource mconn - StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl conn timeout' earlyHintHeadersReceived cont + StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl mnh conn timeout' earlyHintHeadersReceived cont let mcl = lookup "content-length" hs >>= readPositiveInt . S8.unpack isChunked = ("transfer-encoding", CI.mk "chunked") `elem` map (second CI.mk) hs diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs --- a/Network/HTTP/Client/Types.hs +++ b/Network/HTTP/Client/Types.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Network.HTTP.Client.Types ( BodyReader , Connection (..) @@ -39,6 +40,7 @@ , ResponseTimeout (..) , ProxySecureMode (..) , MaxHeaderLength (..) + , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable) @@ -147,12 +149,14 @@ -- -- @since 0.5.0 | OverlongHeaders - -- ^ Either too many headers, or too many total bytes in a - -- single header, were returned by the server, and the - -- memory exhaustion protection in this library has kicked - -- in. + -- ^ Too many total bytes in the HTTP header were returned + -- by the server. -- -- @since 0.5.0 + | TooManyHeaderFields + -- ^ Too many HTTP header fields were returned by the server. + -- + -- @since 0.7.18 | ResponseTimeout -- ^ The server took too long to return a response. This can -- be altered via 'responseTimeout' or @@ -821,6 +825,17 @@ -- -- Since 0.4.7 , managerMaxHeaderLength :: Maybe MaxHeaderLength + -- ^ Configure the maximum size, in bytes, of an HTTP header field. + -- + -- Default: 4096 + -- + -- @since 0.7.17 + , managerMaxNumberHeaders :: Maybe MaxNumberHeaders + -- ^ Configure the maximum number of HTTP header fields. + -- + -- Default: 100 + -- + -- @since 0.7.18 } deriving T.Typeable @@ -845,9 +860,10 @@ , mWrapException :: forall a. Request -> IO a -> IO a , mModifyRequest :: Request -> IO Request , mSetProxy :: Request -> Request - , mModifyResponse :: Response BodyReader -> IO (Response BodyReader) + , mModifyResponse :: Response BodyReader -> IO (Response BodyReader) -- ^ See 'managerProxy' , mMaxHeaderLength :: Maybe MaxHeaderLength + , mMaxNumberHeaders :: Maybe MaxNumberHeaders } deriving T.Typeable @@ -906,4 +922,12 @@ newtype MaxHeaderLength = MaxHeaderLength { unMaxHeaderLength :: Int } - deriving (Eq, Show) + deriving (Eq, Show, Ord, Num, Enum, Bounded, T.Typeable) + +-- | The maximum number of header fields. +-- +-- @since 0.7.18 +newtype MaxNumberHeaders = MaxNumberHeaders + { unMaxNumberHeaders :: Int + } + deriving (Eq, Show, Ord, Num, Enum, Bounded, T.Typeable) diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.7.17 +version: 0.7.18 synopsis: An HTTP client engine description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client diff --git a/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/test-nonet/Network/HTTP/Client/HeadersSpec.hs --- a/test-nonet/Network/HTTP/Client/HeadersSpec.hs +++ b/test-nonet/Network/HTTP/Client/HeadersSpec.hs @@ -23,7 +23,7 @@ , "\nignored" ] (connection, _, _) <- dummyConnection input - statusHeaders <- parseStatusHeaders Nothing connection Nothing (\_ -> return ()) Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing connection Nothing (\_ -> return ()) Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) mempty [ ("foo", "bar") , ("baz", "bin") @@ -37,7 +37,7 @@ ] (conn, out, _) <- dummyConnection input let sendBody = connectionWrite conn "data" - statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody) + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) (Just sendBody) statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ] out >>= (`shouldBe` ["data"]) @@ -47,7 +47,7 @@ ] (conn, out, _) <- dummyConnection input let sendBody = connectionWrite conn "data" - statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody) + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) (Just sendBody) statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] [] out >>= (`shouldBe` []) @@ -59,7 +59,7 @@ , "result" ] (conn, out, inp) <- dummyConnection input - statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ] out >>= (`shouldBe` []) inp >>= (`shouldBe` ["result"]) @@ -78,7 +78,7 @@ callbackResults :: MVar (Seq.Seq [Header]) <- newMVar mempty let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h)) - statusHeaders <- parseStatusHeaders Nothing conn Nothing onEarlyHintHeader Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing onEarlyHintHeader Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [("Link", "") , ("Link", "") @@ -110,7 +110,7 @@ callbackResults :: MVar (Seq.Seq [Header]) <- newMVar mempty let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h)) - statusHeaders <- parseStatusHeaders Nothing conn Nothing onEarlyHintHeader Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing onEarlyHintHeader Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [("Link", "") , ("Link", "") diff --git a/test-nonet/Network/HTTP/Client/ResponseSpec.hs b/test-nonet/Network/HTTP/Client/ResponseSpec.hs --- a/test-nonet/Network/HTTP/Client/ResponseSpec.hs +++ b/test-nonet/Network/HTTP/Client/ResponseSpec.hs @@ -16,7 +16,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do - let getResponse' conn = getResponse Nothing Nothing req (dummyManaged conn) Nothing + let getResponse' conn = getResponse Nothing Nothing Nothing req (dummyManaged conn) Nothing req = parseRequest_ "http://localhost" it "basic" $ do (conn, _, _) <- dummyConnection diff --git a/test-nonet/Network/HTTP/ClientSpec.hs b/test-nonet/Network/HTTP/ClientSpec.hs --- a/test-nonet/Network/HTTP/ClientSpec.hs +++ b/test-nonet/Network/HTTP/ClientSpec.hs @@ -31,6 +31,9 @@ notWindows x = x #endif +crlf :: S.ByteString +crlf = "\r\n" + main :: IO () main = hspec spec @@ -323,3 +326,24 @@ case parseRequest "https://o_O:18446744072699450606" of Left _ -> pure () :: IO () Right req -> error $ "Invalid request: " ++ show req + + it "too many header fields" $ do + let message = S.concat $ + ["HTTP/1.1 200 OK", crlf] <> replicate 120 ("foo: bar" <> crlf) <> [crlf, "body"] + + serveWith message $ \port -> do + man <- newManager $ managerSetMaxNumberHeaders 120 defaultManagerSettings + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + httpLbs req man `shouldThrow` \e -> case e of + HttpExceptionRequest _ TooManyHeaderFields -> True + _otherwise -> False + + it "not too many header fields" $ do + let message = S.concat $ + ["HTTP/1.1 200 OK", crlf] <> replicate 120 ("foo: bar" <> crlf) <> [crlf, "body"] + + serveWith message $ \port -> do + man <- newManager $ managerSetMaxNumberHeaders 121 defaultManagerSettings + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + res <- httpLbs req man + responseBody res `shouldBe` "body"