Merge pull request #549 from marinelli/set-max-headers

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

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,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 []

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

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

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/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-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"