packages feed

http-exchange 0.1.1.0 → 0.2.0.0

raw patch · 6 files changed

+471/−305 lines, 6 filesdep ~byteslicePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: byteslice

API changes (from Hackage documentation)

+ Exchange: exchangeDiscardBody :: Resource -> Bodied Request -> M (Either Exception Response)
- Exchange: HeadersEndOfInput :: HttpException
+ Exchange: HeadersEndOfInput :: {-# UNPACK #-} !Bytes -> HttpException
- Exchange: data HttpException
+ Exchange: data () => HttpException

Files

CHANGELOG.md view
@@ -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.
http-exchange.cabal view
@@ -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)
src-testdep/OkChannel.hs view
@@ -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
src-types/Http/Exchange/Types.hs view
@@ -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"
src/Exchange.hs view
@@ -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
test/Main.hs view
@@ -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"