From 0c15cf98041337598337461fb9831f068633235a Mon Sep 17 00:00:00 2001 From: Daniel Goertzen Date: Tue, 2 Jun 2026 16:29:53 -0500 Subject: [PATCH 1/3] chunked disconnect now throws InvalidChunkHeaders - Fixes issue #168 - Was previously throwing `IncompleteHeaders` which is confusing and misleading. - Untangles readLine functions and call sites. --- http-client/Network/HTTP/Client/Body.hs | 12 +++-- http-client/Network/HTTP/Client/Connection.hs | 51 +++++++++++-------- http-client/Network/HTTP/Client/Headers.hs | 7 +-- 3 files changed, 42 insertions(+), 28 deletions(-) diff --git a/http-client/Network/HTTP/Client/Body.hs b/http-client/Network/HTTP/Client/Body.hs index a44834cb..cb22695d 100644 --- a/http-client/Network/HTTP/Client/Body.hs +++ b/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 diff --git a/http-client/Network/HTTP/Client/Connection.hs b/http-client/Network/HTTP/Client/Connection.hs index a57da553..4358707c 100644 --- a/http-client/Network/HTTP/Client/Connection.hs +++ b/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,9 +33,34 @@ 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 bs + 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 () @@ -43,24 +68,6 @@ 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]) diff --git a/http-client/Network/HTTP/Client/Headers.hs b/http-client/Network/HTTP/Client/Headers.hs index 7c436bd2..3cb53660 100644 --- a/http-client/Network/HTTP/Client/Headers.hs +++ b/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) From 7c1265d998256ae724cd3784df6d8e9267c06804 Mon Sep 17 00:00:00 2001 From: Daniel Goertzen Date: Wed, 3 Jun 2026 10:00:32 -0500 Subject: [PATCH 2/3] fix expectation in conduit test --- http-conduit/test/main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/http-conduit/test/main.hs b/http-conduit/test/main.hs index 632f5f81..9b7d86cb 100644 --- a/http-conduit/test/main.hs +++ b/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 From cefb5eb39a55942345ffafe4a501eda5826a3066 Mon Sep 17 00:00:00 2001 From: Daniel Goertzen Date: Wed, 3 Jun 2026 10:01:09 -0500 Subject: [PATCH 3/3] fix length computation in connectionReadLine --- http-client/Network/HTTP/Client/Connection.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/http-client/Network/HTTP/Client/Connection.hs b/http-client/Network/HTTP/Client/Connection.hs index 4358707c..08ca4249 100644 --- a/http-client/Network/HTTP/Client/Connection.hs +++ b/http-client/Network/HTTP/Client/Connection.hs @@ -47,7 +47,7 @@ connectionReadLineMaybe mhl conn = go id 0 case S.break (== charLF) bs of ("", "") -> pure Nothing -- read returned empty, so EOF (x, rest) -> do - let total' = total + S.length bs + let total' = total + S.length x case fmap unMaxHeaderLength mhl of -- check for length limit Nothing -> pure () Just n -> when (total' > n) $ throwHttp OverlongHeaders