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..08ca4249 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 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 () @@ -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) 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