diff --git a/http-client/ChangeLog.md b/http-client/ChangeLog.md index 0a99830a..5f1405b7 100644 --- a/http-client/ChangeLog.md +++ b/http-client/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/http-client/Network/HTTP/Client.hs b/http-client/Network/HTTP/Client.hs index 97ba8c1a..f0dbbc17 100644 --- a/http-client/Network/HTTP/Client.hs +++ b/http-client/Network/HTTP/Client.hs @@ -113,6 +113,7 @@ module Network.HTTP.Client , managerSetInsecureProxy , managerSetSecureProxy , managerSetMaxHeaderLength + , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy @@ -326,6 +327,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/http-client/Network/HTTP/Client/Core.hs b/http-client/Network/HTTP/Client/Core.hs index 777384f7..016904f5 100644 --- a/http-client/Network/HTTP/Client/Core.hs +++ b/http-client/Network/HTTP/Client/Core.hs @@ -105,7 +105,7 @@ httpRaw' req0 m = do 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/http-client/Network/HTTP/Client/Headers.hs b/http-client/Network/HTTP/Client/Headers.hs index fefe808c..7c436bd2 100644 --- a/http-client/Network/HTTP/Client/Headers.hs +++ b/http-client/Network/HTTP/Client/Headers.hs @@ -28,8 +28,8 @@ charColon = 58 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 @@ parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont 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 @@ parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont 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/http-client/Network/HTTP/Client/Manager.hs b/http-client/Network/HTTP/Client/Manager.hs index fc21ac90..6d0de348 100644 --- a/http-client/Network/HTTP/Client/Manager.hs +++ b/http-client/Network/HTTP/Client/Manager.hs @@ -93,6 +93,7 @@ defaultManagerSettings = ManagerSettings , 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 @@ newManager ms = do then httpsProxy req else httpProxy req , mMaxHeaderLength = managerMaxHeaderLength ms + , mMaxNumberHeaders = managerMaxNumberHeaders ms } return manager @@ -259,7 +261,9 @@ mkCreateConnection ms = do , "\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/http-client/Network/HTTP/Client/Response.hs b/http-client/Network/HTTP/Client/Response.hs index ceb878ef..52c3eb58 100644 --- a/http-client/Network/HTTP/Client/Response.hs +++ b/http-client/Network/HTTP/Client/Response.hs @@ -81,10 +81,10 @@ getRedirectedRequest origReq req hs cookie_jar code 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 @@ getRedirectedRequest origReq req hs cookie_jar code -- 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 @@ lbsResponse res = do } 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/http-client/Network/HTTP/Client/Types.hs b/http-client/Network/HTTP/Client/Types.hs index 646dac79..13bc5ac9 100644 --- a/http-client/Network/HTTP/Client/Types.hs +++ b/http-client/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 @@ module Network.HTTP.Client.Types , ResponseTimeout (..) , ProxySecureMode (..) , MaxHeaderLength (..) + , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable) @@ -147,12 +149,14 @@ data HttpExceptionContent -- -- @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 @@ data ManagerSettings = ManagerSettings -- -- 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 @@ data Manager = Manager , 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 @@ data StreamFileStatus = StreamFileStatus 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/http-client.cabal b/http-client/http-client.cabal index 85862820..ee94b6c8 100644 --- a/http-client/http-client.cabal +++ b/http-client/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/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs index 0d242d44..eb0b04c1 100644 --- a/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs +++ b/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs @@ -23,7 +23,7 @@ spec = describe "HeadersSpec" $ do , "\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 @@ spec = describe "HeadersSpec" $ do ] (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 @@ spec = describe "HeadersSpec" $ do ] (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 @@ spec = describe "HeadersSpec" $ do , "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 @@ spec = describe "HeadersSpec" $ do 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 @@ spec = describe "HeadersSpec" $ do 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/http-client/test-nonet/Network/HTTP/Client/ResponseSpec.hs b/http-client/test-nonet/Network/HTTP/Client/ResponseSpec.hs index 0a5e3abe..cdb8d8ec 100644 --- a/http-client/test-nonet/Network/HTTP/Client/ResponseSpec.hs +++ b/http-client/test-nonet/Network/HTTP/Client/ResponseSpec.hs @@ -16,7 +16,7 @@ main = hspec spec 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/http-client/test-nonet/Network/HTTP/ClientSpec.hs b/http-client/test-nonet/Network/HTTP/ClientSpec.hs index 15bbc30d..6793baa4 100644 --- a/http-client/test-nonet/Network/HTTP/ClientSpec.hs +++ b/http-client/test-nonet/Network/HTTP/ClientSpec.hs @@ -31,6 +31,9 @@ notWindows _ = return () notWindows x = x #endif +crlf :: S.ByteString +crlf = "\r\n" + main :: IO () main = hspec spec @@ -323,3 +326,24 @@ spec = describe "Client" $ do 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"