diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for http-exchange +## 0.2.0.0 -- 2024-01-29 + +* Add incomplete response to headers-end-of-input exception. +* Add exchangeDiscardBody + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/http-exchange.cabal b/http-exchange.cabal --- a/http-exchange.cabal +++ b/http-exchange.cabal @@ -1,65 +1,72 @@ -cabal-version: 3.0 -name: http-exchange -version: 0.1.1.0 -synopsis: Perform HTTP Requests -description: Perform HTTP requests. This uses backpack and is agnostic to the backend. -license: BSD-3-Clause -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2023 Andrew Martin -category: Data -build-type: Simple +cabal-version: 3.0 +name: http-exchange +version: 0.2.0.0 +synopsis: Perform HTTP Requests +description: + Perform HTTP requests. This uses backpack and is agnostic to the backend. + +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2023 Andrew Martin +category: Data +build-type: Simple extra-doc-files: CHANGELOG.md library types - ghc-options: -Wall - exposed-modules: Http.Exchange.Types - build-depends: base >=4.16.3.0 && <5 - hs-source-dirs: src-types + ghc-options: -Wall + exposed-modules: Http.Exchange.Types + build-depends: + , base >=4.16.3.0 && <5 + , byteslice >=0.2.11.1 + + hs-source-dirs: src-types default-language: GHC2021 library testdep - ghc-options: -Wall - exposed-modules: OkChannel + ghc-options: -Wall + exposed-modules: OkChannel build-depends: - , base >=4.16.3.0 && <5 - , byteslice >=0.2.11 + , base >=4.16.3.0 && <5 + , byteslice >=0.2.11 , types - hs-source-dirs: src-testdep + + hs-source-dirs: src-testdep default-language: GHC2021 library - signatures: Channel - ghc-options: -Wall - exposed-modules: Exchange + signatures: Channel + ghc-options: -Wall + exposed-modules: Exchange build-depends: - , base >=4.16.3.0 && <5 - , http-interchange >=0.3.1 - , text >= 2.0 + , base >=4.16.3.0 && <5 + , byteslice >=0.2.11 + , bytesmith >=0.3.9 + , http-interchange >=0.3.1 + , primitive >=0.8 + , text >=2.0 , types - , primitive >=0.8 - , byteslice >=0.2.11 - , bytesmith >=0.3.9 - hs-source-dirs: src + + hs-source-dirs: src default-language: GHC2021 test-suite test - ghc-options: -Wall + ghc-options: -Wall default-language: GHC2021 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs build-depends: - , base >=4.16.3.0 && <5 - , http-interchange >=0.3.1 + , base >=4.16.3.0 && <5 + , byteslice + , bytestring >=0.11 , http-exchange + , http-interchange >=0.3.1 + , primitive >=0.8 + , tasty >=1.4.3 + , tasty-hunit >=0.10.0.3 , testdep - , tasty >=1.4.3 - , tasty-hunit >=0.10.0.3 - , byteslice - , bytestring >=0.11 - , primitive >=0.8 + mixins: - http-exchange (Exchange as OkExchange) - requires (Channel as OkChannel) + http-exchange (Exchange as OkExchange) requires (Channel as OkChannel) diff --git a/src-testdep/OkChannel.hs b/src-testdep/OkChannel.hs --- a/src-testdep/OkChannel.hs +++ b/src-testdep/OkChannel.hs @@ -1,10 +1,10 @@ -{-# language DeriveFunctor #-} -{-# language DerivingStrategies #-} -{-# language KindSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE KindSignatures #-} module OkChannel - ( M(..) - , ReceiveException(..) + ( M (..) + , ReceiveException (..) , SendException , showsPrecReceiveException , showsPrecSendException @@ -14,11 +14,11 @@ ) where import Data.Bytes (Bytes) -import Data.Bytes.Chunks (Chunks(ChunksNil,ChunksCons)) -import Data.Void (Void,absurd) +import Data.Bytes.Chunks (Chunks (ChunksCons, ChunksNil)) +import Data.Void (Void, absurd) -import qualified Data.Bytes as Bytes -import qualified Data.Bytes.Chunks as Chunks +import Data.Bytes qualified as Bytes +import Data.Bytes.Chunks qualified as Chunks type Resource = () @@ -37,18 +37,18 @@ -- The input is peeled off one byte sequence at a time by receive -- We use this feature to feed input byte-by-byte to test streaming -- features. -data M a = M (Chunks -> Bytes -> (Chunks,Bytes,a)) +data M a = M (Chunks -> Bytes -> (Chunks, Bytes, a)) deriving stock (Functor) bindM :: M a -> (a -> M b) -> M b bindM (M f) g = M $ \inbound0 outbound0 -> case f inbound0 outbound0 of - (inbound1,outbound1,a) -> + (inbound1, outbound1, a) -> case g a of M h -> h inbound1 outbound1 pureM :: a -> M a -pureM a = M $ \x y -> (x,y,a) +pureM a = M $ \x y -> (x, y, a) instance Applicative M where pure = pureM @@ -58,19 +58,19 @@ (>>=) = bindM send :: - () - -> Chunks - -> M (Either SendException ()) + () -> + Chunks -> + M (Either SendException ()) send _ b = M $ \inbound outbound -> - (inbound,outbound <> Chunks.concat b,Right ()) + (inbound, outbound <> Chunks.concat b, Right ()) receive :: - () - -> M (Either ReceiveException Bytes) + () -> + M (Either ReceiveException Bytes) receive _ = M $ \inbound0 outbound -> let go inbound = case inbound of - ChunksNil -> (inbound,outbound,Left ExpectedMoreInput) + ChunksNil -> (inbound, outbound, Left ExpectedMoreInput) ChunksCons b ch -> case Bytes.null b of True -> go ch - False -> (ch,outbound,Right b) + False -> (ch, outbound, Right b) in go inbound0 diff --git a/src-types/Http/Exchange/Types.hs b/src-types/Http/Exchange/Types.hs --- a/src-types/Http/Exchange/Types.hs +++ b/src-types/Http/Exchange/Types.hs @@ -1,16 +1,18 @@ -{-# language DeriveAnyClass #-} -{-# language DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} module Http.Exchange.Types - ( HttpException(..) + ( HttpException (..) ) where -import qualified Control.Exception as E +import Control.Exception qualified as E +import Data.Bytes (Bytes) --- | Exceptions that occur when decoding an HTTP response. --- If this happens, the only way to proceed is to --- shut down the connection. Either the server does not --- speak HTTP correct, or there is a mistake in this libary. +{- | Exceptions that occur when decoding an HTTP response. +If this happens, the only way to proceed is to +shut down the connection. Either the server does not +speak HTTP correct, or there is a mistake in this libary. +-} data HttpException = ChunkTooLarge | ChunkedBodyEndOfInput @@ -22,14 +24,34 @@ | ExpectedCrlfAfterChunkLength | ExpectedCrlfBeforeChunkLength | HeadersMalformed - | HeadersEndOfInput + | -- | The entire contents of the response. + HeadersEndOfInput + {-# UNPACK #-} !Bytes | HeadersTooLarge - | ImplementationMistake - -- ^ If this one happens, there is a mistake in this + | -- | If this one happens, there is a mistake in this -- library. + ImplementationMistake | NonNumericChunkLength | PipelinedResponses | TransferEncodingUnrecognized | TransferEncodingDuplicated - deriving stock (Show) deriving anyclass (E.Exception) + +instance Show HttpException where + showsPrec _ ChunkTooLarge = showString "ChunkTooLarge" + showsPrec _ ChunkedBodyEndOfInput = showString "ChunkedBodyEndOfInput" + showsPrec _ NonchunkedBodyEndOfInput = showString "NonchunkedBodyEndOfInput" + showsPrec _ ContentLengthDuplicated = showString "ContentLengthDuplicated" + showsPrec _ ContentLengthMalformed = showString "ContentLengthMalformed" + showsPrec _ ContentLengthTooLarge = showString "ContentLengthTooLarge" + showsPrec _ ExpectedCrlfAfterChunk = showString "ExpectedCrlfAfterChunk" + showsPrec _ ExpectedCrlfAfterChunkLength = showString "ExpectedCrlfAfterChunkLength" + showsPrec _ ExpectedCrlfBeforeChunkLength = showString "ExpectedCrlfBeforeChunkLength" + showsPrec _ HeadersMalformed = showString "HeadersMalformed" + showsPrec _ HeadersEndOfInput {} = showString "HeadersEndOfInput{..}" + showsPrec _ HeadersTooLarge = showString "HeadersTooLarge" + showsPrec _ ImplementationMistake = showString "ImplementationMistake" + showsPrec _ NonNumericChunkLength = showString "NonNumericChunkLength" + showsPrec _ PipelinedResponses = showString "PipelinedResponses" + showsPrec _ TransferEncodingUnrecognized = showString "TransferEncodingUnrecognized" + showsPrec _ TransferEncodingDuplicated = showString "TransferEncodingDuplicated" diff --git a/src/Exchange.hs b/src/Exchange.hs --- a/src/Exchange.hs +++ b/src/Exchange.hs @@ -1,45 +1,47 @@ -{-# language DeriveAnyClass #-} -{-# language DerivingStrategies #-} -{-# language DuplicateRecordFields #-} -{-# language LambdaCase #-} -{-# language OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Exchange - ( Exception(..) - , HttpException(..) + ( Exception (..) + , HttpException (..) , exchange + , exchangeDiscardBody ) where -import Channel (M,Resource,SendException,ReceiveException,send,receive) +import Channel (M, ReceiveException, Resource, SendException, receive, send) import Control.Monad (when) -import Data.Char (ord) import Data.Bytes (Bytes) -import Data.Bytes.Chunks (Chunks(ChunksCons,ChunksNil)) +import Data.Bytes.Chunks (Chunks (ChunksCons, ChunksNil)) +import Data.Bytes.Parser (Parser) +import Data.Char (ord) import Data.Word (Word64) -import Http.Bodied (Bodied(Bodied)) +import Http.Bodied (Bodied (Bodied)) import Http.Exchange.Types (HttpException) -import Http.Header (Header(Header)) -import Http.Types (Request,Response,Headers,LookupException(Duplicate,Missing)) +import Http.Header (Header (Header)) +import Http.Types (Headers, LookupException (Duplicate, Missing), Request, Response) import Text.Read (readMaybe) -import Data.Bytes.Parser (Parser) -import qualified Data.Bytes.Parser as Parser -import qualified Data.Bytes.Parser.Latin as Latin -import qualified Http.Exchange.Types as E -import qualified Data.Bytes as Bytes -import qualified Data.Bytes.Chunks as Chunks -import qualified Data.Text as T -import qualified Http.Header -import qualified Http.Headers as Headers -import qualified Http.Request as Request -import qualified Http.Response as Response -import qualified Http.Bodied -import qualified Control.Exception -import qualified Channel +import Channel qualified +import Control.Exception qualified +import Data.Bytes qualified as Bytes +import Data.Bytes.Chunks qualified as Chunks +import Data.Bytes.Parser qualified as Parser +import Data.Bytes.Parser.Latin qualified as Latin +import Data.Text qualified as T +import Http.Bodied qualified +import Http.Exchange.Types qualified as E +import Http.Header qualified +import Http.Headers qualified as Headers +import Http.Request qualified as Request +import Http.Response qualified as Response -data Continuation = Continuation - !Instruction - !Chunks -- these chunks are in reverse order +data Continuation + = Continuation + !Instruction + !Chunks -- these chunks are in reverse order -- Not exported data Instruction @@ -54,9 +56,9 @@ !Word64 -- chunk length accumulator | PostCr -- We already got the CR after the chunk length !Int -- how much input we need to consume, but we need to consume the LF first - | Done - -- ^ We got all the chunks, and we got the zero-length chunk + | -- | We got all the chunks, and we got the zero-length chunk -- at the end, and we got the trailing CRLF. We are done. + Done data TransferEncoding = Nonchunked @@ -64,70 +66,119 @@ -- | An exception that occurs during an HTTP exchange. data Exception - = Http -- ^ The response was not a valid HTTP response + = -- | The response was not a valid HTTP response + Http !HttpException - | Send - -- ^ Transport exception while sending. When backed by stream sockets, - -- exceptions like @ECONNRESET@ show up here. + | -- | Transport exception while sending. When backed by stream sockets, + -- exceptions like @ECONNRESET@ show up here. + Send !SendException - | Receive - -- ^ Transport exception while receiving. Depending on the backend, - -- this may or may not include an end-of-input exception. For stream - -- sockets, end-of-input is not presented as an exception. It is - -- presented as a zero-length result. + | -- | Transport exception while receiving. Depending on the backend, + -- this may or may not include an end-of-input exception. For stream + -- sockets, end-of-input is not presented as an exception. It is + -- presented as a zero-length result. + Receive !ReceiveException deriving anyclass (Control.Exception.Exception) instance Show Exception where - showsPrec d (Http e) = showParen (d > 10) - (showString "Http " . showsPrec 11 e) - showsPrec d (Send e) = showParen (d > 10) - (showString "Send " . Channel.showsPrecSendException 11 e) - showsPrec d (Receive e) = showParen (d > 10) - (showString "Receive " . Channel.showsPrecReceiveException 11 e) + showsPrec d (Http e) = + showParen + (d > 10) + (showString "Http " . showsPrec 11 e) + showsPrec d (Send e) = + showParen + (d > 10) + (showString "Send " . Channel.showsPrecSendException 11 e) + showsPrec d (Receive e) = + showParen + (d > 10) + (showString "Receive " . Channel.showsPrecReceiveException 11 e) --- | Send an HTTP request and await a response. This function takes --- responsibility for encoding the request and decoding the response. --- It deals with the @Transfer-Encoding@ of the response and supports --- both chunked and nonchunked responses. +{- | Variant of @exchange@ that discards the response body. This can be +used safely even when the size of the response body is greater than +the amount of memory available. + +This is intended as a resident-memory optimization for situations where +the caller ignores the response body. +-} +exchangeDiscardBody :: + Resource -> + Bodied Request -> -- http request line and headers + M (Either Exception Response) +exchangeDiscardBody ctx req = do + let enc = Request.bodiedToChunks req + send ctx enc >>= \case + Left err -> pure (Left (Send err)) + Right () -> receiveResponseDiscardBody ctx + +{- | Send an HTTP request and await a response. This function takes +responsibility for encoding the request and decoding the response. +It deals with the @Transfer-Encoding@ of the response and supports +both chunked and nonchunked responses. +-} exchange :: - Resource - -> Bodied Request -- http request line and headers - -> M (Either Exception (Bodied Response)) + Resource -> + Bodied Request -> -- http request line and headers + M (Either Exception (Bodied Response)) exchange ctx req = do let enc = Request.bodiedToChunks req send ctx enc >>= \case Left err -> pure (Left (Send err)) - Right () -> receiveResponse ctx + Right () -> receiveResponsePreserveBody ctx -receiveResponse :: - Resource - -> M (Either Exception (Bodied Response)) -receiveResponse !ctx = do - let go !oldOutput = receive ctx >>= \case - Left err -> pure (Left (Receive err)) - Right newOutput -> case Bytes.length newOutput of - 0 -> pure (Left (Http E.HeadersEndOfInput)) - _ -> do - let output = oldOutput <> newOutput - case splitEndOfHeaders output of - Nothing -> if Bytes.length output > 16000 +-- Returns response. Also returns leftovers that belong to the body. +receiveHeaders :: + Resource -> + M (Either Exception (Response, Bytes)) +receiveHeaders !ctx = go mempty + where + go :: Bytes -> M (Either Exception (Response, Bytes)) + go !oldOutput = + receive ctx >>= \case + Left err -> pure (Left (Receive err)) + Right newOutput -> case Bytes.length newOutput of + 0 -> pure (Left (Http (E.HeadersEndOfInput oldOutput))) + _ -> do + let output = oldOutput <> newOutput + case splitEndOfHeaders output of + Nothing -> + if Bytes.length output > 16000 then pure (Left (Http E.HeadersTooLarge)) else go output - Just (pre,post) -> case Response.decode 128 pre of - Nothing -> pure (Left (Http E.HeadersMalformed)) - Just resp@Response.Response{headers} -> case lookupTransferEncoding headers of - Left err -> pure (Left (Http err)) - Right enc -> case enc of - Nonchunked -> handleNonchunkedBody ctx resp post headers - Chunked -> handleChunkedBody ctx resp post - go mempty + Just (pre, post) -> case Response.decode 128 pre of + Nothing -> pure (Left (Http E.HeadersMalformed)) + Just resp -> pure (Right (resp, post)) +receiveResponsePreserveBody :: + Resource -> + M (Either Exception (Bodied Response)) +receiveResponsePreserveBody !ctx = + receiveHeaders ctx >>= \case + Left err -> pure (Left err) + Right (resp@Response.Response {headers}, post) -> case lookupTransferEncoding headers of + Left err -> pure (Left (Http err)) + Right enc -> case enc of + Nonchunked -> handleNonchunkedBody ctx resp post headers + Chunked -> handleChunkedBody ctx resp post + +receiveResponseDiscardBody :: + Resource -> + M (Either Exception Response) +receiveResponseDiscardBody !ctx = + receiveHeaders ctx >>= \case + Left err -> pure (Left err) + Right (resp@Response.Response {headers}, post) -> case lookupTransferEncoding headers of + Left err -> pure (Left (Http err)) + Right enc -> case enc of + Nonchunked -> discardNonchunkedBody ctx resp post headers + Chunked -> discardChunkedBody ctx resp post + handleChunkedBody :: - Resource - -> Response - -> Bytes - -> M (Either Exception (Bodied Response)) + Resource -> + Response -> + Bytes -> + M (Either Exception (Bodied Response)) handleChunkedBody !ctx resp !input0 = do let go contA !inputA = case Parser.parseBytes (parserChunked contA) inputA of Parser.Failure e -> pure (Left (Http e)) @@ -135,15 +186,19 @@ -- We expect that parserChunked consumes all input, so we check -- here to be certain that it actually does. 0 -> case contB of - Continuation Done revChunks -> pure $ Right $ Bodied - { metadata = resp - , body = Chunks.reverse revChunks - } - _ -> receive ctx >>= \case - Right inputB -> case Bytes.length inputB of - 0 -> pure (Left (Http E.ChunkedBodyEndOfInput)) - _ -> go contB inputB - Left err -> pure (Left (Receive err)) + Continuation Done revChunks -> + pure $ + Right $ + Bodied + { metadata = resp + , body = Chunks.reverse revChunks + } + _ -> + receive ctx >>= \case + Right inputB -> case Bytes.length inputB of + 0 -> pure (Left (Http E.ChunkedBodyEndOfInput)) + _ -> go contB inputB + Left err -> pure (Left (Receive err)) _ -> pure (Left (Http E.ImplementationMistake)) let cont0 = Continuation (ChunkLength 0) ChunksNil go cont0 input0 @@ -172,61 +227,93 @@ parserChunkedMore total (n - m) chunks1 parserChunkedMorePost :: Int -> Chunks -> Parser HttpException s Continuation -parserChunkedMorePost !total !chunks0 = Latin.opt >>= \case - Just '\r' -> parserChunkedMorePostCr total chunks0 - Just _ -> Parser.fail E.ExpectedCrlfAfterChunk - Nothing -> pure (Continuation (More total 0) chunks0) +parserChunkedMorePost !total !chunks0 = + Latin.opt >>= \case + Just '\r' -> parserChunkedMorePostCr total chunks0 + Just _ -> Parser.fail E.ExpectedCrlfAfterChunk + Nothing -> pure (Continuation (More total 0) chunks0) parserChunkedMorePostCr :: Int -> Chunks -> Parser HttpException s Continuation -parserChunkedMorePostCr !total !chunks0 = Latin.opt >>= \case - Just '\n' -> case total of - 0 -> pure (Continuation Done chunks0) - _ -> parserChunkedChunkLength 0 chunks0 - Just _ -> Parser.fail E.ExpectedCrlfAfterChunk - Nothing -> pure (Continuation (MorePostCr total) chunks0) +parserChunkedMorePostCr !total !chunks0 = + Latin.opt >>= \case + Just '\n' -> case total of + 0 -> pure (Continuation Done chunks0) + _ -> parserChunkedChunkLength 0 chunks0 + Just _ -> Parser.fail E.ExpectedCrlfAfterChunk + Nothing -> pure (Continuation (MorePostCr total) chunks0) parserChunkedChunkLength :: Word64 -> Chunks -> Parser HttpException s Continuation -parserChunkedChunkLength !acc !chunks0 = if acc > 100_000_000 - then Parser.fail E.ChunkTooLarge - else Latin.opt >>= \case - Nothing -> pure (Continuation (ChunkLength acc) chunks0) - Just c -> case c of - '\r' -> Latin.opt >>= \case - Just d -> case d of - '\n' -> do - let !acc' = fromIntegral acc :: Int - parserChunkedMore acc' acc' chunks0 - _ -> Parser.fail E.ExpectedCrlfAfterChunkLength - Nothing -> pure (Continuation (PostCr (fromIntegral acc)) chunks0) - _ | c >= '0', c <= '9' -> parserChunkedChunkLength (acc * 16 + fromIntegral (ord c - 0x30)) chunks0 - _ | c >= 'a', c <= 'f' -> parserChunkedChunkLength (acc * 16 + fromIntegral (ord c - (0x61 - 10))) chunks0 - _ | c >= 'A', c <= 'F' -> parserChunkedChunkLength (acc * 16 + fromIntegral (ord c - (0x41 - 10))) chunks0 - _ -> Parser.fail E.NonNumericChunkLength +parserChunkedChunkLength !acc !chunks0 = + if acc > 100_000_000 + then Parser.fail E.ChunkTooLarge + else + Latin.opt >>= \case + Nothing -> pure (Continuation (ChunkLength acc) chunks0) + Just c -> case c of + '\r' -> + Latin.opt >>= \case + Just d -> case d of + '\n' -> do + let !acc' = fromIntegral acc :: Int + parserChunkedMore acc' acc' chunks0 + _ -> Parser.fail E.ExpectedCrlfAfterChunkLength + Nothing -> pure (Continuation (PostCr (fromIntegral acc)) chunks0) + _ | c >= '0', c <= '9' -> parserChunkedChunkLength (acc * 16 + fromIntegral (ord c - 0x30)) chunks0 + _ | c >= 'a', c <= 'f' -> parserChunkedChunkLength (acc * 16 + fromIntegral (ord c - (0x61 - 10))) chunks0 + _ | c >= 'A', c <= 'F' -> parserChunkedChunkLength (acc * 16 + fromIntegral (ord c - (0x41 - 10))) chunks0 + _ -> Parser.fail E.NonNumericChunkLength parserChunkedChunkLengthPostCr :: Int -> Chunks -> Parser HttpException s Continuation -parserChunkedChunkLengthPostCr !n !chunks0 = Latin.opt >>= \case - Just d -> case d of - '\n' -> parserChunkedMore n n chunks0 - _ -> Parser.fail E.ExpectedCrlfAfterChunkLength - Nothing -> pure (Continuation (PostCr n) chunks0) +parserChunkedChunkLengthPostCr !n !chunks0 = + Latin.opt >>= \case + Just d -> case d of + '\n' -> parserChunkedMore n n chunks0 + _ -> Parser.fail E.ExpectedCrlfAfterChunkLength + Nothing -> pure (Continuation (PostCr n) chunks0) +-- Note: We could do much better. Upfront, we could allocate a +-- mutable byte array that is big enough to hold the entire body. +-- This would require changing the signature to make a primitive +-- offering reception into mutable byte arrays available. handleNonchunkedBody :: Resource -> Response -> Bytes -> Headers -> M (Either Exception (Bodied Response)) handleNonchunkedBody ctx resp !post !headers = case lookupContentLength headers of Left err -> pure (Left (Http err)) Right len -> do let finish reversedChunks n = case compare n 0 of LT -> pure (Left (Http E.PipelinedResponses)) - EQ -> pure $ Right $ Bodied - { metadata = resp - , body = Chunks.reverse reversedChunks - } - GT -> receive ctx >>= \case - Right chunk -> case Bytes.length chunk of - 0 -> pure (Left (Http E.NonchunkedBodyEndOfInput)) - _ -> finish (ChunksCons chunk reversedChunks) (n - Bytes.length chunk) - Left err -> pure (Left (Receive err)) + EQ -> + pure $ + Right $ + Bodied + { metadata = resp + , body = Chunks.reverse reversedChunks + } + GT -> + receive ctx >>= \case + Right chunk -> case Bytes.length chunk of + 0 -> pure (Left (Http E.NonchunkedBodyEndOfInput)) + _ -> finish (ChunksCons chunk reversedChunks) (n - Bytes.length chunk) + Left err -> pure (Left (Receive err)) finish (ChunksCons post ChunksNil) (len - Bytes.length post) +-- This is not great. It relies on the GC to clean up the received +-- bytes for us. It would be better to reuse a mutable byte array +-- and receive into it repeatedly. +discardNonchunkedBody :: Resource -> Response -> Bytes -> Headers -> M (Either Exception Response) +discardNonchunkedBody ctx resp !post !headers = case lookupContentLength headers of + Left err -> pure (Left (Http err)) + Right len -> do + let finish n = case compare n 0 of + LT -> pure (Left (Http E.PipelinedResponses)) + EQ -> pure $ Right $ resp + GT -> + receive ctx >>= \case + Right chunk -> case Bytes.length chunk of + 0 -> pure (Left (Http E.NonchunkedBodyEndOfInput)) + _ -> finish (n - Bytes.length chunk) + Left err -> pure (Left (Receive err)) + finish (len - Bytes.length post) + splitEndOfHeaders :: Bytes -> Maybe (Bytes, Bytes) splitEndOfHeaders !b = case Bytes.findTetragramIndex 0x0D 0x0A 0x0D 0x0A b of Nothing -> Nothing @@ -235,7 +322,7 @@ lookupTransferEncoding :: Headers -> Either HttpException TransferEncoding lookupTransferEncoding !hdrs = case Headers.lookupTransferEncoding hdrs of - Right Header{value} -> case value of + Right Header {value} -> case value of "chunked" -> Right Chunked _ -> Left E.TransferEncodingUnrecognized Left Missing -> Right Nonchunked @@ -246,8 +333,40 @@ case Headers.lookupContentLength hdrs of Left Missing -> Right 0 Left Duplicate -> Left E.ContentLengthDuplicated - Right Header{value} -> case readMaybe (T.unpack value) of + Right Header {value} -> case readMaybe (T.unpack value) of Nothing -> Left E.ContentLengthMalformed Just i -> do when (i > 8_000_000_000) (Left E.ContentLengthTooLarge) Right i + +discardChunkedBody :: + Resource -> + Response -> + Bytes -> + M (Either Exception Response) +discardChunkedBody !ctx resp !input0 = do + let go :: Instruction -> Bytes -> M (Either Exception Response) + go instrA !inputA = case Parser.parseBytes (parserChunked (upgradeInstruction instrA)) inputA of + Parser.Failure e -> pure (Left (Http e)) + Parser.Success (Parser.Slice _ leftoverLen contB) -> + let instrB = downgradeContinuation contB + in case leftoverLen of + -- We expect that parserChunked consumes all input, so we check + -- here to be certain that it actually does. + 0 -> case instrB of + Done -> pure $ Right $ resp + _ -> + receive ctx >>= \case + Right inputB -> case Bytes.length inputB of + 0 -> pure (Left (Http E.ChunkedBodyEndOfInput)) + _ -> go instrB inputB + Left err -> pure (Left (Receive err)) + _ -> pure (Left (Http E.ImplementationMistake)) + let instr0 = ChunkLength 0 + go instr0 input0 + +upgradeInstruction :: Instruction -> Continuation +upgradeInstruction i = Continuation i ChunksNil + +downgradeContinuation :: Continuation -> Instruction +downgradeContinuation (Continuation i _) = i diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,131 +1,144 @@ -{-# language DuplicateRecordFields #-} -{-# language OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} -import Test.Tasty (TestTree,testGroup,defaultMain) -import Test.Tasty.HUnit (testCase,(@=?)) import Data.Bytes (Bytes) -import Http.Request (Request(Request),RequestLine(RequestLine)) -import Http.Types (Response, Bodied(Bodied), Header(Header)) -import OkChannel (M(M)) -import Data.Bytes.Chunks (Chunks(ChunksCons,ChunksNil)) +import Data.Bytes.Chunks (Chunks (ChunksCons, ChunksNil)) +import Http.Request (Request (Request), RequestLine (RequestLine)) +import Http.Types (Bodied (Bodied), Header (Header), Response) +import OkChannel (M (M)) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@=?)) -import qualified Data.Bytes as Bytes -import qualified Data.Bytes.Chunks as Chunks -import qualified GHC.Exts as Exts -import qualified OkExchange as E -import qualified Http.Header -import qualified Http.Headers as Headers -import qualified Http.Bodied -import qualified Http.Request as Request -import qualified Data.Bytes.Text.Ascii as Ascii +import Data.Bytes qualified as Bytes +import Data.Bytes.Chunks qualified as Chunks +import Data.Bytes.Text.Ascii qualified as Ascii +import GHC.Exts qualified as Exts +import Http.Bodied qualified +import Http.Header qualified +import Http.Headers qualified as Headers +import Http.Request qualified as Request +import OkExchange qualified as E main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "tests" - [ testCase "get-a" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespA) - body @=? ChunksNil - input @=? mempty - output @=? Chunks.concat (Request.bodiedToChunks getReqA) - , testCase "get-chunked-a" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespChunkedA) - body @=? ChunksNil - input @=? mempty - output @=? Chunks.concat (Request.bodiedToChunks getReqA) - , testCase "get-chunked-byte-by-byte-a" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (bytesToSingleByteChunks getRespChunkedA) - body @=? ChunksNil - input @=? mempty - output @=? Chunks.concat (Request.bodiedToChunks getReqA) - , testCase "get-body-a" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespBodyA) - input @=? mempty - body @=? ChunksCons (Ascii.fromString "helloworld") ChunksNil - output @=? Chunks.concat (Request.bodiedToChunks getReqA) - , testCase "get-chunked-b" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespChunkedB) - Ascii.fromString "hello to my friends." @=? Chunks.concat body - mempty @=? input - Chunks.concat (Request.bodiedToChunks getReqA) @=? output - , testCase "get-chunked-byte-by-byte-b" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (bytesToSingleByteChunks getRespChunkedB) - Ascii.fromString "hello to my friends." @=? Chunks.concat body - mempty @=? input - Chunks.concat (Request.bodiedToChunks getReqA) @=? output - , testCase "get-chunked-two-by-two-b" $ do - (input,output,Bodied{body}) <- evaluateM (E.exchange () getReqA) (bytesToDoubletonByteChunks getRespChunkedB) - Ascii.fromString "hello to my friends." @=? Chunks.concat body - mempty @=? input - Chunks.concat (Request.bodiedToChunks getReqA) @=? output - ] +tests = + testGroup + "tests" + [ testCase "get-a" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespA) + body @=? ChunksNil + input @=? mempty + output @=? Chunks.concat (Request.bodiedToChunks getReqA) + , testCase "get-chunked-a" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespChunkedA) + body @=? ChunksNil + input @=? mempty + output @=? Chunks.concat (Request.bodiedToChunks getReqA) + , testCase "get-chunked-byte-by-byte-a" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (bytesToSingleByteChunks getRespChunkedA) + body @=? ChunksNil + input @=? mempty + output @=? Chunks.concat (Request.bodiedToChunks getReqA) + , testCase "get-body-a" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespBodyA) + input @=? mempty + body @=? ChunksCons (Ascii.fromString "helloworld") ChunksNil + output @=? Chunks.concat (Request.bodiedToChunks getReqA) + , testCase "get-chunked-b" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (Chunks.fromBytes getRespChunkedB) + Ascii.fromString "hello to my friends." @=? Chunks.concat body + mempty @=? input + Chunks.concat (Request.bodiedToChunks getReqA) @=? output + , testCase "get-chunked-byte-by-byte-b" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (bytesToSingleByteChunks getRespChunkedB) + Ascii.fromString "hello to my friends." @=? Chunks.concat body + mempty @=? input + Chunks.concat (Request.bodiedToChunks getReqA) @=? output + , testCase "get-chunked-two-by-two-b" $ do + (input, output, Bodied {body}) <- evaluateM (E.exchange () getReqA) (bytesToDoubletonByteChunks getRespChunkedB) + Ascii.fromString "hello to my friends." @=? Chunks.concat body + mempty @=? input + Chunks.concat (Request.bodiedToChunks getReqA) @=? output + ] bytesToSingleByteChunks :: Bytes -> Chunks -bytesToSingleByteChunks = Bytes.foldr' - (\w acc -> ChunksCons (Bytes.singleton w) acc - ) ChunksNil +bytesToSingleByteChunks = + Bytes.foldr' + ( \w acc -> ChunksCons (Bytes.singleton w) acc + ) + ChunksNil bytesToDoubletonByteChunks :: Bytes -> Chunks bytesToDoubletonByteChunks b0 = go (Exts.toList b0) - where - go (x : y : zs) = ChunksCons (Exts.fromList [x,y]) (go zs) + where + go (x : y : zs) = ChunksCons (Exts.fromList [x, y]) (go zs) go [x] = ChunksCons (Bytes.singleton x) ChunksNil go [] = ChunksNil evaluateM :: - M (Either E.Exception (Bodied Response)) - -> Chunks -- prebuilt response - -> IO (Chunks,Bytes,Bodied Response) + M (Either E.Exception (Bodied Response)) -> + Chunks -> -- prebuilt response + IO (Chunks, Bytes, Bodied Response) evaluateM (M f) resp = case f resp mempty of - (input,output,r) -> case r of + (input, output, r) -> case r of Left e -> case e of E.Http err -> fail ("exchange http protocol failure: " ++ show err) E.Receive err -> fail ("exchange http transport receive failure: " ++ show err) - Right b -> pure (input,output,b) + Right b -> pure (input, output, b) getReqA :: Bodied Request -getReqA = Bodied - { metadata = Request - { requestLine=RequestLine - { method = "GET" - , path = "/health" - } - , headers = Headers.fromArray $ Exts.fromList - [ Header{name="Host",value="example.com"} - ] +getReqA = + Bodied + { metadata = + Request + { requestLine = + RequestLine + { method = "GET" + , path = "/health" + } + , headers = + Headers.fromArray $ + Exts.fromList + [ Header {name = "Host", value = "example.com"} + ] + } + , body = mempty } - , body = mempty - } getRespA :: Bytes -getRespA = Ascii.fromString - "HTTP/1.1 200 OK\r\n\ - \Server: testsuite/1.2.3\r\n\ - \Content-Type: text/plain\r\n\r\n" +getRespA = + Ascii.fromString + "HTTP/1.1 200 OK\r\n\ + \Server: testsuite/1.2.3\r\n\ + \Content-Type: text/plain\r\n\r\n" getRespBodyA :: Bytes -getRespBodyA = Ascii.fromString - "HTTP/1.1 200 OK\r\n\ - \Server: testsuite/1.2.3\r\n\ - \Content-Type: text/plain\r\n\ - \Content-Length: 10\r\n\r\n\ - \helloworld" +getRespBodyA = + Ascii.fromString + "HTTP/1.1 200 OK\r\n\ + \Server: testsuite/1.2.3\r\n\ + \Content-Type: text/plain\r\n\ + \Content-Length: 10\r\n\r\n\ + \helloworld" getRespChunkedA :: Bytes -getRespChunkedA = Ascii.fromString - "HTTP/1.1 200 OK\r\n\ - \Server: testsuite/1.2.3\r\n\ - \Transfer-Encoding: chunked\r\n\ - \Content-Type: text/plain\r\n\r\n\ - \0\r\n\r\n" +getRespChunkedA = + Ascii.fromString + "HTTP/1.1 200 OK\r\n\ + \Server: testsuite/1.2.3\r\n\ + \Transfer-Encoding: chunked\r\n\ + \Content-Type: text/plain\r\n\r\n\ + \0\r\n\r\n" getRespChunkedB :: Bytes -getRespChunkedB = Ascii.fromString - "HTTP/1.1 200 OK\r\n\ - \Server: testsuite/1.2.3\r\n\ - \Transfer-Encoding: chunked\r\n\ - \Content-Type: text/plain\r\n\r\n\ - \5\r\nhello\r\n\ - \f\r\n to my friends.\r\n\ - \0\r\n\r\n" +getRespChunkedB = + Ascii.fromString + "HTTP/1.1 200 OK\r\n\ + \Server: testsuite/1.2.3\r\n\ + \Transfer-Encoding: chunked\r\n\ + \Content-Type: text/plain\r\n\r\n\ + \5\r\nhello\r\n\ + \f\r\n to my friends.\r\n\ + \0\r\n\r\n"