Merge pull request #514 from tfausak/gh-502-max-header-length

Allow customizing max header length

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

@@ -148,11 +148,12 @@ makeLengthReader cleanup count0 Connection {..} = do
                         return bs
 
 makeChunkedReader
-  :: IO () -- ^ cleanup
+  :: Maybe MaxHeaderLength
+  -> IO () -- ^ cleanup
   -> Bool -- ^ raw
   -> Connection
   -> IO BodyReader
-makeChunkedReader cleanup raw conn@Connection {..} = do
+makeChunkedReader mhl cleanup raw conn@Connection {..} = do
     icount <- newIORef 0
     return $ do
       bs <- go icount
@@ -201,11 +202,11 @@ makeChunkedReader cleanup raw conn@Connection {..} = do
           | otherwise = return (x, 0)
 
     requireNewline = do
-        bs <- connectionReadLine conn
+        bs <- connectionReadLine mhl conn
         unless (S.null bs) $ throwHttp InvalidChunkHeaders
 
     readHeader = do
-        bs <- connectionReadLine conn
+        bs <- connectionReadLine mhl conn
         case parseHex bs of
             Nothing -> throwHttp InvalidChunkHeaders
             Just hex -> return (bs `S.append` "\r\n", hex)
@@ -228,9 +229,9 @@ makeChunkedReader cleanup raw conn@Connection {..} = do
         | otherwise = Nothing
 
     readTrailersRaw = do
-        bs <- connectionReadLine conn
+        bs <- connectionReadLine mhl conn
         if S.null bs
         then pure "\r\n"
         else (bs `S.append` "\r\n" `S.append`) <$> readTrailersRaw
 
-    consumeTrailers = connectionDropTillBlankLine conn
+    consumeTrailers = connectionDropTillBlankLine mhl conn

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

@@ -30,28 +30,29 @@ import Data.Function (fix)
 import Data.Maybe (listToMaybe)
 import Data.Word (Word8)
 
-
-connectionReadLine :: Connection -> IO ByteString
-connectionReadLine conn = do
+connectionReadLine :: Maybe MaxHeaderLength -> Connection -> IO ByteString
+connectionReadLine mhl conn = do
     bs <- connectionRead conn
     when (S.null bs) $ throwHttp IncompleteHeaders
-    connectionReadLineWith conn bs
+    connectionReadLineWith mhl conn bs
 
 -- | Keep dropping input until a blank line is found.
-connectionDropTillBlankLine :: Connection -> IO ()
-connectionDropTillBlankLine conn = fix $ \loop -> do
-    bs <- connectionReadLine conn
+connectionDropTillBlankLine :: Maybe MaxHeaderLength -> Connection -> IO ()
+connectionDropTillBlankLine mhl conn = fix $ \loop -> do
+    bs <- connectionReadLine mhl conn
     unless (S.null bs) loop
 
-connectionReadLineWith :: Connection -> ByteString -> IO ByteString
-connectionReadLineWith conn bs0 =
+connectionReadLineWith :: Maybe 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
-                when (total' > 4096) $ throwHttp OverlongHeaders
+                case fmap unMaxHeaderLength mhl of
+                    Nothing -> pure ()
+                    Just n -> when (total' > n) $ 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 timeout' req mconn cont
+        getResponse (mMaxHeaderLength 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

@@ -26,8 +26,8 @@ charColon = 58
 charPeriod = 46
 
 
-parseStatusHeaders :: Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
-parseStatusHeaders conn timeout' cont
+parseStatusHeaders :: Maybe MaxHeaderLength -> Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
+parseStatusHeaders mhl conn timeout' cont
     | Just k <- cont = getStatusExpectContinue k
     | otherwise      = getStatus
   where
@@ -46,22 +46,22 @@ parseStatusHeaders conn timeout' cont
             Nothing -> sendBody >> getStatus
 
     nextStatusHeaders = do
-        (s, v) <- nextStatusLine
+        (s, v) <- nextStatusLine mhl
         if statusCode s == 100
-            then connectionDropTillBlankLine conn >> return Nothing
+            then connectionDropTillBlankLine mhl conn >> return Nothing
             else Just . StatusHeaders s v A.<$> parseHeaders (0 :: Int) id
 
-    nextStatusLine :: IO (Status, HttpVersion)
-    nextStatusLine = do
+    nextStatusLine :: Maybe 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 conn bs >>= parseStatus 3
+        connectionReadLineWith mhl conn bs >>= parseStatus mhl 3
 
-    parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)
-    parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1)
-    parseStatus _ bs = do
+    parseStatus :: Maybe 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
             (code, bs3) = S.break (== charSpace) $ S.dropWhile (== charSpace) bs2
             msg = S.dropWhile (== charSpace) bs3
@@ -84,7 +84,7 @@ parseStatusHeaders conn timeout' cont
 
     parseHeaders 100 _ = throwHttp OverlongHeaders
     parseHeaders count front = do
-        line <- connectionReadLine conn
+        line <- connectionReadLine mhl conn
         if S.null line
             then return $ front []
             else do

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

@@ -92,6 +92,7 @@ defaultManagerSettings = ManagerSettings
     , managerModifyResponse = return
     , managerProxyInsecure = defaultProxy
     , managerProxySecure = defaultProxy
+    , managerMaxHeaderLength = Just $ MaxHeaderLength 4096
     }
 
 -- | Create a 'Manager'. The @Manager@ will be shut down automatically via
@@ -131,6 +132,7 @@ newManager ms = do
                 if secure req
                     then httpsProxy req
                     else httpProxy req
+            , mMaxHeaderLength = managerMaxHeaderLength ms
             }
     return manager
 
@@ -257,7 +259,7 @@ mkCreateConnection ms = do
                     , "\r\n"
                     ]
                 parse conn = do
-                    StatusHeaders status _ _ <- parseStatusHeaders conn Nothing Nothing
+                    StatusHeaders status _ _ <- parseStatusHeaders (managerMaxHeaderLength ms) conn Nothing Nothing
                     unless (status == status200) $
                         throwHttp $ ProxyConnectException ultHost ultPort status
                 in tlsProxyConnection

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

@@ -84,14 +84,15 @@ lbsResponse res = do
         { responseBody = L.fromChunks bss
         }
 
-getResponse :: Maybe Int
+getResponse :: Maybe MaxHeaderLength
+            -> Maybe Int
             -> Request
             -> Managed Connection
             -> Maybe (IO ()) -- ^ Action to run in case of a '100 Continue'.
             -> IO (Response BodyReader)
-getResponse timeout' req@(Request {..}) mconn cont = do
+getResponse mhl timeout' req@(Request {..}) mconn cont = do
     let conn = managedResource mconn
-    StatusHeaders s version hs <- parseStatusHeaders conn timeout' cont
+    StatusHeaders s version hs <- parseStatusHeaders mhl conn timeout' cont
     let mcl = lookup "content-length" hs >>= readPositiveInt . S8.unpack
         isChunked = ("transfer-encoding", CI.mk "chunked") `elem` map (second CI.mk) hs
 
@@ -115,7 +116,7 @@ getResponse timeout' req@(Request {..}) mconn cont = do
             else do
                 body1 <-
                     if isChunked
-                        then makeChunkedReader (cleanup True) rawBody conn
+                        then makeChunkedReader mhl (cleanup True) rawBody conn
                         else
                             case mcl of
                                 Just len -> makeLengthReader (cleanup True) len conn

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

@@ -38,6 +38,7 @@ module Network.HTTP.Client.Types
     , StreamFileStatus (..)
     , ResponseTimeout (..)
     , ProxySecureMode (..)
+    , MaxHeaderLength (..)
     ) where
 
 import qualified Data.Typeable as T (Typeable)
@@ -802,6 +803,7 @@ data ManagerSettings = ManagerSettings
     -- Default: respect the @proxy@ value on the @Request@ itself.
     --
     -- Since 0.4.7
+    , managerMaxHeaderLength :: Maybe MaxHeaderLength
     }
     deriving T.Typeable
 
@@ -828,6 +830,7 @@ data Manager = Manager
     , mSetProxy :: Request -> Request
     , mModifyResponse      :: Response BodyReader -> IO (Response BodyReader)
     -- ^ See 'managerProxy'
+    , mMaxHeaderLength :: Maybe MaxHeaderLength
     }
     deriving T.Typeable
 
@@ -879,3 +882,9 @@ data StreamFileStatus = StreamFileStatus
     , thisChunkSize :: Int
     }
     deriving (Eq, Show, Ord, T.Typeable)
+
+-- | The maximum header size in bytes.
+newtype MaxHeaderLength = MaxHeaderLength
+    { unMaxHeaderLength :: Int
+    }
+    deriving (Eq, Show)

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 (return ()) False conn
+        reader <- makeChunkedReader Nothing (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 (return ()) False conn
+        reader <- makeChunkedReader Nothing (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 (return ()) False conn
+        reader <- makeChunkedReader Nothing (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 (return ()) False conn
+        reader <- makeChunkedReader Nothing (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 (return ()) True conn
+        reader <- makeChunkedReader Nothing (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 (return ()) True conn
+        reader <- makeChunkedReader Nothing (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 (return ()) True conn
+        reader <- makeChunkedReader Nothing (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 (return ()) True conn
+        reader <- makeChunkedReader Nothing (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

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

@@ -20,7 +20,7 @@ spec = describe "HeadersSpec" $ do
                 , "\nignored"
                 ]
         (connection, _, _) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders connection Nothing Nothing
+        statusHeaders <- parseStatusHeaders Nothing connection Nothing Nothing
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)
             [ ("foo", "bar")
             , ("baz", "bin")
@@ -34,7 +34,7 @@ spec = describe "HeadersSpec" $ do
                 ]
         (conn, out, _) <- dummyConnection input
         let sendBody = connectionWrite conn "data"
-        statusHeaders <- parseStatusHeaders conn Nothing (Just sendBody)
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing (Just sendBody)
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]
         out >>= (`shouldBe` ["data"])
 
@@ -44,7 +44,7 @@ spec = describe "HeadersSpec" $ do
                 ]
         (conn, out, _) <- dummyConnection input
         let sendBody = connectionWrite conn "data"
-        statusHeaders <- parseStatusHeaders conn Nothing (Just sendBody)
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing (Just sendBody)
         statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) []
         out >>= (`shouldBe` [])
 
@@ -56,7 +56,7 @@ spec = describe "HeadersSpec" $ do
                 , "result"
                 ]
         (conn, out, inp) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders conn Nothing Nothing
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing Nothing
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]
         out >>= (`shouldBe` [])
         inp >>= (`shouldBe` ["result"])

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 req (dummyManaged conn) Nothing
+    let getResponse' conn = getResponse Nothing Nothing req (dummyManaged conn) Nothing
         req = parseRequest_ "http://localhost"
     it "basic" $ do
         (conn, _, _) <- dummyConnection