Add the possibility to set the maximum number of header fields

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`.

http-client/Network/HTTP/Client.hs

@@ -113,6 +113,7 @@ module Network.HTTP.Client
     , managerSetInsecureProxy
     , managerSetSecureProxy
     , managerSetMaxHeaderLength
+    , managerSetMaxNumberHeaders
     , ProxyOverride
     , proxyFromRequest
     , noProxy
@@ -324,7 +325,12 @@ managerSetProxy po = managerSetInsecureProxy po . managerSetSecureProxy po
 -- @since 0.7.17
 managerSetMaxHeaderLength :: Int -> ManagerSettings -> ManagerSettings
 managerSetMaxHeaderLength l manager = manager
-    { managerMaxHeaderLength = Just $ MaxHeaderLength l }
+    { managerMaxHeaderLength = MaxHeaderLength l }
+
+-- @since 0.7.18
+managerSetMaxNumberHeaders :: Int -> ManagerSettings -> ManagerSettings
+managerSetMaxNumberHeaders n manager = manager
+    { managerMaxNumberHeaders = MaxNumberHeaders n }
 
 -- $example1
 -- = Example Usage

http-client/Network/HTTP/Client/Body.hs

@@ -148,7 +148,7 @@ makeLengthReader cleanup count0 Connection {..} = do
                         return bs
 
 makeChunkedReader
-  :: Maybe MaxHeaderLength
+  :: MaxHeaderLength
   -> IO () -- ^ cleanup
   -> Bool -- ^ raw
   -> Connection

http-client/Network/HTTP/Client/Connection.hs

@@ -31,29 +31,29 @@ import Data.Function (fix)
 import Data.Maybe (listToMaybe)
 import Data.Word (Word8)
 
-connectionReadLine :: Maybe MaxHeaderLength -> Connection -> IO ByteString
+connectionReadLine :: MaxHeaderLength -> Connection -> IO ByteString
 connectionReadLine mhl conn = do
     bs <- connectionRead conn
     when (S.null bs) $ throwHttp IncompleteHeaders
     connectionReadLineWith mhl conn bs
 
 -- | Keep dropping input until a blank line is found.
-connectionDropTillBlankLine :: Maybe MaxHeaderLength -> Connection -> IO ()
+connectionDropTillBlankLine :: MaxHeaderLength -> Connection -> IO ()
 connectionDropTillBlankLine mhl conn = fix $ \loop -> do
     bs <- connectionReadLine mhl conn
     unless (S.null bs) loop
 
-connectionReadLineWith :: Maybe MaxHeaderLength -> Connection -> ByteString -> IO ByteString
+connectionReadLineWith :: MaxHeaderLength -> Connection -> ByteString -> IO ByteString
 connectionReadLineWith mhl conn bs0 =
     go bs0 id 0
   where
     go bs front total =
         case S.break (== charLF) bs of
             (_, "") -> do
                 let total' = total + S.length bs
-                case fmap unMaxHeaderLength mhl of
-                    Nothing -> pure ()
-                    Just n -> when (total' > n) $ throwHttp OverlongHeaders
+                when (total > unMaxHeaderLength mhl) $ do
+                    -- We reached the maximum length for an header field.
+                    throwHttp OverlongHeaders
                 bs' <- connectionRead conn
                 when (S.null bs') $ throwHttp IncompleteHeaders
                 go bs' (front . (bs:)) total'

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

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 :: MaxHeaderLength -> 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
@@ -60,15 +60,15 @@ parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont
                          return $ Just $ StatusHeaders s' v' (earlyHeaders <> earlyHeaders') reqHeaders
            | otherwise -> (Just <$>) $ StatusHeaders s v mempty A.<$> parseHeaders 0 id
 
-    nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
+    nextStatusLine :: MaxHeaderLength -> IO (Status, HttpVersion)
     nextStatusLine mhl = do
         -- Ensure that there is some data coming in. If not, we want to signal
         -- this as a connection problem and not a protocol problem.
         bs <- connectionRead conn
         when (S.null bs) $ throwHttp NoResponseDataReceived
         connectionReadLineWith mhl conn bs >>= parseStatus mhl 3
 
-    parseStatus :: Maybe MaxHeaderLength -> Int -> S.ByteString -> IO (Status, HttpVersion)
+    parseStatus :: MaxHeaderLength -> Int -> S.ByteString -> IO (Status, HttpVersion)
     parseStatus mhl i bs | S.null bs && i > 0 = connectionReadLine mhl conn >>= parseStatus mhl (i - 1)
     parseStatus _ _ bs = do
         let (ver, bs2) = S.break (== charSpace) bs
@@ -91,9 +91,15 @@ parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont
             Just (i, "") -> Just i
             _ -> Nothing
 
+    guardMaxNumberHeaders :: Int -> IO ()
+    guardMaxNumberHeaders count =
+        when (count >= unMaxNumberHeaders mnh) $ do
+            -- We reached the maximum number of header fields.
+            throwHttp TooManyHeaders
+
     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 +113,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 []

http-client/Network/HTTP/Client/Manager.hs

@@ -92,7 +92,8 @@ defaultManagerSettings = ManagerSettings
     , managerModifyResponse = return
     , managerProxyInsecure = defaultProxy
     , managerProxySecure = defaultProxy
-    , managerMaxHeaderLength = Just $ MaxHeaderLength 4096
+    , managerMaxHeaderLength = 4096
+    , managerMaxNumberHeaders = 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

http-client/Network/HTTP/Client/Response.hs

@@ -81,18 +81,18 @@ 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
             (False, True) -> do
                 -- 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)
                 --
@@ -113,15 +113,16 @@ lbsResponse res = do
         { responseBody = L.fromChunks bss
         }
 
-getResponse :: Maybe MaxHeaderLength
+getResponse :: MaxHeaderLength
+            -> 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
 

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,9 @@ module Network.HTTP.Client.Types
     , ResponseTimeout (..)
     , ProxySecureMode (..)
     , MaxHeaderLength (..)
+    , noMaxHeaderLength
+    , MaxNumberHeaders (..)
+    , noMaxNumberHeaders
     ) where
 
 import qualified Data.Typeable as T (Typeable)
@@ -147,12 +151,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 a single header field were
+                   -- returned by the server.
                    --
                    -- @since 0.5.0
+                   | TooManyHeaders
+                   -- ^ Too many 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
@@ -820,7 +826,18 @@ data ManagerSettings = ManagerSettings
     -- Default: respect the @proxy@ value on the @Request@ itself.
     --
     -- Since 0.4.7
-    , managerMaxHeaderLength :: Maybe MaxHeaderLength
+    , managerMaxHeaderLength :: MaxHeaderLength
+    -- ^ Configure the maximum size, in bytes, of an HTTP header field.
+    --
+    -- Default: 4096
+    --
+    -- @since 0.7.17
+    , managerMaxNumberHeaders :: MaxNumberHeaders
+    -- ^ Configure the maximum number of HTTP header fields.
+    --
+    -- Default: 100
+    --
+    -- @since 0.7.18
     }
     deriving T.Typeable
 
@@ -845,9 +862,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
+    , mMaxHeaderLength :: MaxHeaderLength
+    , mMaxNumberHeaders :: MaxNumberHeaders
     }
     deriving T.Typeable
 
@@ -906,4 +924,18 @@ data StreamFileStatus = StreamFileStatus
 newtype MaxHeaderLength = MaxHeaderLength
     { unMaxHeaderLength :: Int
     }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Ord, Num, Enum, Bounded, T.Typeable)
+
+noMaxHeaderLength :: MaxHeaderLength
+noMaxHeaderLength = maxBound
+
+-- | The maximum number of header fields.
+--
+-- @since 0.7.18
+newtype MaxNumberHeaders = MaxNumberHeaders
+    { unMaxNumberHeaders :: Int
+    }
+    deriving (Eq, Show, Ord, Num, Enum, Bounded, T.Typeable)
+
+noMaxNumberHeaders :: MaxNumberHeaders
+noMaxNumberHeaders = maxBound

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: <http://www.stackage.org/package/http-client>.
 homepage:            https://github.com/snoyberg/http-client

http-client/test-nonet/Network/HTTP/Client/BodySpec.hs

@@ -22,7 +22,7 @@ spec = describe "BodySpec" $ do
         (conn, _, input) <- dummyConnection
             [ "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed"
             ]
-        reader <- makeChunkedReader Nothing (return ()) False conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) False conn
         body <- brConsume reader
         S.concat body `shouldBe` "hello world"
         input' <- input
@@ -33,7 +33,7 @@ spec = describe "BodySpec" $ do
         (conn, _, input) <- dummyConnection
             [ "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: ignored\r\nbut: consumed\r\n\r\nnot consumed"
             ]
-        reader <- makeChunkedReader Nothing (return ()) False conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) False conn
         body <- brConsume reader
         S.concat body `shouldBe` "hello world"
         input' <- input
@@ -43,7 +43,7 @@ spec = describe "BodySpec" $ do
     it "chunked, pieces" $ do
         (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack
             "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed"
-        reader <- makeChunkedReader Nothing (return ()) False conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) False conn
         body <- brConsume reader
         S.concat body `shouldBe` "hello world"
         input' <- input
@@ -53,7 +53,7 @@ spec = describe "BodySpec" $ do
     it "chunked, pieces, with trailers" $ do
         (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack
             "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: ignored\r\nbut: consumed\r\n\r\nnot consumed"
-        reader <- makeChunkedReader Nothing (return ()) False conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) False conn
         body <- brConsume reader
         S.concat body `shouldBe` "hello world"
         input' <- input
@@ -64,7 +64,7 @@ spec = describe "BodySpec" $ do
         (conn, _, input) <- dummyConnection
             [ "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed"
             ]
-        reader <- makeChunkedReader Nothing (return ()) True conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) True conn
         body <- brConsume reader
         S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n"
         input' <- input
@@ -75,7 +75,7 @@ spec = describe "BodySpec" $ do
         (conn, _, input) <- dummyConnection
             [ "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\nnot consumed"
             ]
-        reader <- makeChunkedReader Nothing (return ()) True conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) True conn
         body <- brConsume reader
         S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\n"
         input' <- input
@@ -85,7 +85,7 @@ spec = describe "BodySpec" $ do
     it "chunked, pieces, raw" $ do
         (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack
             "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed"
-        reader <- makeChunkedReader Nothing (return ()) True conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) True conn
         body <- brConsume reader
         S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n"
         input' <- input
@@ -95,7 +95,7 @@ spec = describe "BodySpec" $ do
     it "chunked, pieces, raw, with trailers" $ do
         (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack
             "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\nnot consumed"
-        reader <- makeChunkedReader Nothing (return ()) True conn
+        reader <- makeChunkedReader noMaxHeaderLength (return ()) True conn
         body <- brConsume reader
         S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\n"
         input' <- input