chunked disconnect now throws InvalidChunkHeaders

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

@@ -202,11 +202,11 @@ makeChunkedReader mhl cleanup raw conn@Connection {..} = do
           | otherwise = return (x, 0)
 
     requireNewline = do
-        bs <- connectionReadLine mhl conn
+        bs <- readLine
         unless (S.null bs) $ throwHttp InvalidChunkHeaders
 
     readHeader = do
-        bs <- connectionReadLine mhl conn
+        bs <- readLine
         case parseHex bs of
             Nothing -> throwHttp InvalidChunkHeaders
             Just hex -> return (bs `S.append` "\r\n", hex)
@@ -229,9 +229,15 @@ makeChunkedReader mhl cleanup raw conn@Connection {..} = do
         | otherwise = Nothing
 
     readTrailersRaw = do
-        bs <- connectionReadLine mhl conn
+        bs <- readLine
         if S.null bs
         then pure "\r\n"
         else (bs `S.append` "\r\n" `S.append`) <$> readTrailersRaw
 
     consumeTrailers = connectionDropTillBlankLine mhl conn
+
+    readLine = do
+        mbs <- connectionReadLineMaybe mhl conn
+        case mbs of
+            Nothing -> throwHttp InvalidChunkHeaders
+            Just bs -> pure bs

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

@@ -3,7 +3,7 @@
 {-# LANGUAGE ViewPatterns #-}
 module Network.HTTP.Client.Connection
     ( connectionReadLine
-    , connectionReadLineWith
+    , connectionReadLineMaybe
     , connectionDropTillBlankLine
     , connectionUnreadLine
     , dummyConnection
@@ -33,34 +33,41 @@ import Data.Word (Word8)
 
 connectionReadLine :: Maybe MaxHeaderLength -> Connection -> IO ByteString
 connectionReadLine mhl conn = do
-    bs <- connectionRead conn
-    when (S.null bs) $ throwHttp IncompleteHeaders
-    connectionReadLineWith mhl conn bs
+    mbs <- connectionReadLineMaybe mhl conn
+    case mbs of
+        Nothing -> throwHttp IncompleteHeaders
+        Just bs -> pure bs
+
+-- | Return a line or Nothing if EOF is reached.
+connectionReadLineMaybe :: Maybe MaxHeaderLength -> Connection -> IO (Maybe ByteString)
+connectionReadLineMaybe mhl conn = go id 0
+  where
+    go front total = do
+        bs <- connectionRead conn
+        case S.break (== charLF) bs of
+            ("", "") -> pure Nothing -- read returned empty, so EOF
+            (x, rest) -> do
+                let total' = total + S.length x
+                case fmap unMaxHeaderLength mhl of -- check for length limit
+                    Nothing -> pure ()
+                    Just n -> when (total' > n) $ throwHttp OverlongHeaders
+                if S.null rest
+                    then -- no LF so keep going
+                        go (front . (bs :)) total'
+                    else do
+                        -- put back everything after LF
+                        let
+                            rest' = S.drop 1 rest
+                        unless (S.null rest') $ connectionUnread conn rest'
+                        -- compose final result
+                        pure $! Just $! killCR $! S.concat $! front [x]
 
 -- | Keep dropping input until a blank line is found.
 connectionDropTillBlankLine :: Maybe 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 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
-                bs' <- connectionRead conn
-                when (S.null bs') $ throwHttp IncompleteHeaders
-                go bs' (front . (bs:)) total'
-            (x, S.drop 1 -> y) -> do
-                unless (S.null y) $! connectionUnread conn y
-                return $! killCR $! S.concat $! front [x]
-
 connectionUnreadLine :: Connection -> ByteString -> IO ()
 connectionUnreadLine conn line = do
   connectionUnread conn (S.pack [charCR, charLF])

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

@@ -64,9 +64,10 @@ parseStatusHeaders mhl mnh conn timeout' onEarlyHintHeaders cont
     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
+        mbs <- connectionReadLineMaybe mhl conn
+        case mbs of
+            Nothing -> throwHttp NoResponseDataReceived
+            Just bs -> parseStatus mhl 3 bs
 
     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)

http-conduit/test/main.hs

@@ -326,7 +326,7 @@ main = do
             manager <- newManager tlsManagerSettings
             eres <- try $ httpLbs req manager
             liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
-             `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders))
+             `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))
         it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do
             req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
             manager <- newManager tlsManagerSettings