Add the possibility to set the maximum number of headers

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 l manager = manager
+    { managerMaxNumberHeaders = Just $ MaxNumberHeaders l }
+
 -- $example1
 -- = Example Usage
 --

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 :: 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,18 @@ parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont
             Just (i, "") -> Just i
             _ -> Nothing
 
+    guardMaxNumberHeaders :: Int -> IO ()
+    guardMaxNumberHeaders count = case fmap unMaxNumberHeaders mnh of
+        -- We reached the maximum number of headers, let's throw an error
+        Just n | count >= n -> throwHttp OverlongHeaders
+        -- We didn't reach the maximum number of headers yet
+        Just _ -> pure ()
+        -- We do not have any limit on the number of headers
+        Nothing -> pure ()
+
     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 +116,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

@@ -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

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)
                 --
@@ -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
 

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

@@ -39,6 +39,7 @@ module Network.HTTP.Client.Types
     , ResponseTimeout (..)
     , ProxySecureMode (..)
     , MaxHeaderLength (..)
+    , MaxNumberHeaders (..)
     ) where
 
 import qualified Data.Typeable as T (Typeable)
@@ -821,6 +822,17 @@ data ManagerSettings = ManagerSettings
     --
     -- Since 0.4.7
     , managerMaxHeaderLength :: Maybe MaxHeaderLength
+    -- ^ TODO
+    --
+    -- Default: TODO
+    --
+    -- @since TODO
+    , managerMaxNumberHeaders :: Maybe MaxNumberHeaders
+    -- ^ TODO
+    --
+    -- Default: TODO
+    --
+    -- @since 0.7.18
     }
     deriving T.Typeable
 
@@ -845,9 +857,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 +919,12 @@ data StreamFileStatus = StreamFileStatus
 newtype MaxHeaderLength = MaxHeaderLength
     { unMaxHeaderLength :: Int
     }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Ord, T.Typeable)
+
+-- | The maximum number of header lines.
+--
+-- @since TODO
+newtype MaxNumberHeaders = MaxNumberHeaders
+    { unMaxNumberHeaders :: Int
+    }
+    deriving (Eq, Show, Ord, T.Typeable)

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", "</foo.js>")
             , ("Link", "</bar.js>")
@@ -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", "</foo.js>")
             , ("Link", "</bar.js>")

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

http-conduit/Network/HTTP/Simple.hs

@@ -110,7 +110,6 @@ import qualified Data.Aeson as A
 
 import qualified Data.Traversable as T
 import Control.Exception (throw, throwIO, Exception)
-import Data.Monoid
 import Data.Typeable (Typeable)
 import qualified Data.Conduit as C
 import Data.Conduit (runConduit, (.|), ConduitM)