From c8f652d1d0dda523ae5f3c9e2480e544656b3285 Mon Sep 17 00:00:00 2001 From: Brian McKeon Date: Thu, 18 Jan 2024 09:11:30 -0500 Subject: [PATCH] Reformatted. Added workflows. --- .github/workflows/build-arm64-main.yaml | 18 ++ .github/workflows/build-arm64-pr.yaml | 14 + .github/workflows/build-x64-main.yaml | 18 ++ .github/workflows/build-x64-pr.yaml | 14 + .gitignore | 1 + http-exchange.cabal | 95 +++--- src-testdep/OkChannel.hs | 56 ++-- src-types/Http/Exchange/Types.hs | 29 +- src/Exchange.hs | 380 +++++++++++++----------- test/Main.hs | 211 +++++++------ 10 files changed, 475 insertions(+), 361 deletions(-) create mode 100644 .github/workflows/build-arm64-main.yaml create mode 100644 .github/workflows/build-arm64-pr.yaml create mode 100644 .github/workflows/build-x64-main.yaml create mode 100644 .github/workflows/build-x64-pr.yaml diff --git a/.github/workflows/build-arm64-main.yaml b/.github/workflows/build-arm64-main.yaml new file mode 100644 index 0000000..4c35da9 --- /dev/null +++ b/.github/workflows/build-arm64-main.yaml @@ -0,0 +1,18 @@ +name: main arm64 + +on: + push: + branches: + - main + + workflow_dispatch: + branches: + - main + +jobs: + call-workflow: + uses: layer-3-communications/.github/.github/workflows/build-haskell.yaml@main + with: + build-arch: arm64 + slack-name: ${{ github.ref_name }} + secrets: inherit diff --git a/.github/workflows/build-arm64-pr.yaml b/.github/workflows/build-arm64-pr.yaml new file mode 100644 index 0000000..7385322 --- /dev/null +++ b/.github/workflows/build-arm64-pr.yaml @@ -0,0 +1,14 @@ +name: pull request arm64 + +on: + pull_request: + branches: + - "*" + +jobs: + call-workflow: + uses: layer-3-communications/.github/.github/workflows/build-haskell.yaml@main + with: + build-arch: arm64 + slack-name: ${{ github.event.pull_request.head.ref }} + secrets: inherit diff --git a/.github/workflows/build-x64-main.yaml b/.github/workflows/build-x64-main.yaml new file mode 100644 index 0000000..7277f20 --- /dev/null +++ b/.github/workflows/build-x64-main.yaml @@ -0,0 +1,18 @@ +name: main x64 + +on: + push: + branches: + - main + + workflow_dispatch: + branches: + - main + +jobs: + call-workflow: + uses: layer-3-communications/.github/.github/workflows/build-haskell.yaml@main + with: + build-arch: x64 + slack-name: ${{ github.ref_name }} + secrets: inherit diff --git a/.github/workflows/build-x64-pr.yaml b/.github/workflows/build-x64-pr.yaml new file mode 100644 index 0000000..a82dd19 --- /dev/null +++ b/.github/workflows/build-x64-pr.yaml @@ -0,0 +1,14 @@ +name: pull request x64 + +on: + pull_request: + branches: + - "*" + +jobs: + call-workflow: + uses: layer-3-communications/.github/.github/workflows/build-haskell.yaml@main + with: + build-arch: x64 + slack-name: ${{ github.event.pull_request.head.ref }} + secrets: inherit diff --git a/.gitignore b/.gitignore index 28d589b..cde1485 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.vscode/ dist dist-* cabal-dev diff --git a/http-exchange.cabal b/http-exchange.cabal index a6c2293..dbf5a81 100644 --- a/http-exchange.cabal +++ b/http-exchange.cabal @@ -1,67 +1,72 @@ -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 +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 + 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 + , 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 index 32f299a..15da032 100644 --- a/src-testdep/OkChannel.hs +++ b/src-testdep/OkChannel.hs @@ -1,24 +1,24 @@ -{-# language DeriveFunctor #-} -{-# language DerivingStrategies #-} -{-# language KindSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE KindSignatures #-} -module OkChannel - ( M(..) - , ReceiveException(..) - , SendException - , showsPrecReceiveException - , showsPrecSendException - , Resource - , send - , receive - ) where +module OkChannel ( + M (..), + ReceiveException (..), + SendException, + showsPrecReceiveException, + showsPrecSendException, + Resource, + send, + receive, +) 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 @@ showsPrecSendException _ x _ = absurd x -- 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 @@ instance Monad M where (>>=) = 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 index a72fb1e..0404dea 100644 --- a/src-types/Http/Exchange/Types.hs +++ b/src-types/Http/Exchange/Types.hs @@ -1,17 +1,18 @@ -{-# language DeriveAnyClass #-} -{-# language DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} -module Http.Exchange.Types - ( HttpException(..) - ) where +module Http.Exchange.Types ( + HttpException (..), +) where +import Control.Exception qualified as E import Data.Bytes (Bytes) -import qualified Control.Exception as E --- | 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 @@ -23,13 +24,13 @@ data HttpException | ExpectedCrlfAfterChunkLength | ExpectedCrlfBeforeChunkLength | HeadersMalformed - | HeadersEndOfInput + | -- | The entire contents of the response. + HeadersEndOfInput {-# UNPACK #-} !Bytes - -- ^ The entire contents of the response. | 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 diff --git a/src/Exchange.hs b/src/Exchange.hs index f6f1cf8..bf628cf 100644 --- a/src/Exchange.hs +++ b/src/Exchange.hs @@ -1,46 +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(..) - , exchange - , exchangeDiscardBody - ) where +module Exchange ( + 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 @@ -55,9 +56,9 @@ data Instruction !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 @@ -65,52 +66,61 @@ data TransferEncoding -- | 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) --- | 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. +{- | 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) + 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. +{- | 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 @@ -119,52 +129,56 @@ exchange ctx req = do -- Returns response. Also returns leftovers that belong to the body. receiveHeaders :: - Resource - -> M (Either Exception (Response, Bytes)) + Resource -> + M (Either Exception (Response, Bytes)) receiveHeaders !ctx = go mempty - where + 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 -> pure (Right (resp, post)) + 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 -> 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 + 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 + 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)) @@ -172,15 +186,19 @@ handleChunkedBody !ctx resp !input0 = do -- 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 @@ -209,43 +227,49 @@ parserChunkedMore !total !n !chunks0 = case n of 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. @@ -257,15 +281,19 @@ handleNonchunkedBody ctx resp !post !headers = case lookupContentLength headers 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 @@ -278,11 +306,12 @@ discardNonchunkedBody ctx resp !post !headers = case lookupContentLength headers 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)) + 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) @@ -311,27 +340,28 @@ lookupContentLength !hdrs = Right i discardChunkedBody :: - Resource - -> Response - -> Bytes - -> M (Either Exception Response) + 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 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 diff --git a/test/Main.hs b/test/Main.hs index 3be5594..829deb0 100644 --- 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"