{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Exchange
  ( Exception (..)
  , HttpException (..)
  , exchange
  , exchangeDiscardBody
  ) where

import Channel (M, ReceiveException, Resource, SendException, receive, send)
import Control.Monad (when)
import Data.Bytes (Bytes)
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.Exchange.Types (HttpException)
import Http.Header (Header (Header))
import Http.Types (Headers, LookupException (Duplicate, Missing), Request, Response)
import Text.Read (readMaybe)

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

-- Not exported
data Instruction
  = More -- we are in the middle of a chunk
      !Int -- how much input was requested (zero is special)
      !Int -- how much more input do we need to consume
  | MorePostCr
      !Int -- how much input was requested for the last chunk
  | ChunkLength
      -- We are in the middle (or at the beginning) of chunk length,
      -- the leading CRLF has already been consumed
      !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
  | -- | 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
  | Chunked

-- | An exception that occurs during an HTTP exchange.
data Exception
  = -- | The response was not a valid HTTP response
    Http
      !HttpException
  | -- | Transport exception while sending. When backed by stream sockets,
    -- exceptions like @ECONNRESET@ show up here.
    Send
      !SendException
  | -- | 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 (Show Exception
Typeable Exception
(Typeable Exception, Show Exception) =>
(Exception -> SomeException)
-> (SomeException -> Maybe Exception)
-> (Exception -> String)
-> Exception Exception
SomeException -> Maybe Exception
Exception -> String
Exception -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: Exception -> SomeException
toException :: Exception -> SomeException
$cfromException :: SomeException -> Maybe Exception
fromException :: SomeException -> Maybe Exception
$cdisplayException :: Exception -> String
displayException :: Exception -> String
Control.Exception.Exception)

instance Show Exception where
  showsPrec :: Int -> Exception -> ShowS
showsPrec Int
d (Http HttpException
e) =
    Bool -> ShowS -> ShowS
showParen
      (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
      (String -> ShowS
showString String
"Http " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HttpException -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 HttpException
e)
  showsPrec Int
d (Send SendException
e) =
    Bool -> ShowS -> ShowS
showParen
      (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
      (String -> ShowS
showString String
"Send " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SendException -> ShowS
Channel.showsPrecSendException Int
11 SendException
e)
  showsPrec Int
d (Receive ReceiveException
e) =
    Bool -> ShowS -> ShowS
showParen
      (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
      (String -> ShowS
showString String
"Receive " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReceiveException -> ShowS
Channel.showsPrecReceiveException Int
11 ReceiveException
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.
-}
exchangeDiscardBody ::
  Resource ->
  Bodied Request -> -- http request line and headers
  M (Either Exception Response)
exchangeDiscardBody :: Resource -> Bodied Request -> M (Either Exception Response)
exchangeDiscardBody Resource
ctx Bodied Request
req = do
  let enc :: Chunks
enc = Bodied Request -> Chunks
Request.bodiedToChunks Bodied Request
req
  Resource -> Chunks -> M (Either SendException ())
send Resource
ctx Chunks
enc M (Either SendException ())
-> (Either SendException () -> M (Either Exception Response))
-> M (Either Exception Response)
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SendException
err -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (SendException -> Exception
Send SendException
err))
    Right () -> Resource -> M (Either Exception Response)
receiveResponseDiscardBody Resource
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))
exchange :: Resource
-> Bodied Request -> M (Either Exception (Bodied Response))
exchange Resource
ctx Bodied Request
req = do
  let enc :: Chunks
enc = Bodied Request -> Chunks
Request.bodiedToChunks Bodied Request
req
  Resource -> Chunks -> M (Either SendException ())
send Resource
ctx Chunks
enc M (Either SendException ())
-> (Either SendException ()
    -> M (Either Exception (Bodied Response)))
-> M (Either Exception (Bodied Response))
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SendException
err -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (SendException -> Exception
Send SendException
err))
    Right () -> Resource -> M (Either Exception (Bodied Response))
receiveResponsePreserveBody Resource
ctx

-- Returns response. Also returns leftovers that belong to the body.
receiveHeaders ::
  Resource ->
  M (Either Exception (Response, Bytes))
receiveHeaders :: Resource -> M (Either Exception (Response, Bytes))
receiveHeaders !Resource
ctx = Bytes -> M (Either Exception (Response, Bytes))
go Bytes
forall a. Monoid a => a
mempty
 where
  go :: Bytes -> M (Either Exception (Response, Bytes))
  go :: Bytes -> M (Either Exception (Response, Bytes))
go !Bytes
oldOutput =
    Resource -> M (Either ReceiveException Bytes)
receive Resource
ctx M (Either ReceiveException Bytes)
-> (Either ReceiveException Bytes
    -> M (Either Exception (Response, Bytes)))
-> M (Either Exception (Response, Bytes))
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ReceiveException
err -> Either Exception (Response, Bytes)
-> M (Either Exception (Response, Bytes))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Response, Bytes)
forall a b. a -> Either a b
Left (ReceiveException -> Exception
Receive ReceiveException
err))
      Right Bytes
newOutput -> case Bytes -> Int
Bytes.length Bytes
newOutput of
        Int
0 -> Either Exception (Response, Bytes)
-> M (Either Exception (Response, Bytes))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Response, Bytes)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http (Bytes -> HttpException
E.HeadersEndOfInput Bytes
oldOutput)))
        Int
_ -> do
          let output :: Bytes
output = Bytes
oldOutput Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Bytes
newOutput
          case Bytes -> Maybe (Bytes, Bytes)
splitEndOfHeaders Bytes
output of
            Maybe (Bytes, Bytes)
Nothing ->
              if Bytes -> Int
Bytes.length Bytes
output Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16000
                then Either Exception (Response, Bytes)
-> M (Either Exception (Response, Bytes))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Response, Bytes)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.HeadersTooLarge))
                else Bytes -> M (Either Exception (Response, Bytes))
go Bytes
output
            Just (Bytes
pre, Bytes
post) -> case Int -> Bytes -> Maybe Response
Response.decode Int
128 Bytes
pre of
              Maybe Response
Nothing -> Either Exception (Response, Bytes)
-> M (Either Exception (Response, Bytes))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Response, Bytes)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.HeadersMalformed))
              Just Response
resp -> Either Exception (Response, Bytes)
-> M (Either Exception (Response, Bytes))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Response, Bytes) -> Either Exception (Response, Bytes)
forall a b. b -> Either a b
Right (Response
resp, Bytes
post))

receiveResponsePreserveBody ::
  Resource ->
  M (Either Exception (Bodied Response))
receiveResponsePreserveBody :: Resource -> M (Either Exception (Bodied Response))
receiveResponsePreserveBody !Resource
ctx =
  Resource -> M (Either Exception (Response, Bytes))
receiveHeaders Resource
ctx M (Either Exception (Response, Bytes))
-> (Either Exception (Response, Bytes)
    -> M (Either Exception (Bodied Response)))
-> M (Either Exception (Bodied Response))
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Exception
err -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left Exception
err)
    Right (resp :: Response
resp@Response.Response {Headers
headers :: Headers
$sel:headers:Response :: Response -> Headers
headers}, Bytes
post) -> case Headers -> Either HttpException TransferEncoding
lookupTransferEncoding Headers
headers of
      Left HttpException
err -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
err))
      Right TransferEncoding
enc -> case TransferEncoding
enc of
        TransferEncoding
Nonchunked -> Resource
-> Response
-> Bytes
-> Headers
-> M (Either Exception (Bodied Response))
handleNonchunkedBody Resource
ctx Response
resp Bytes
post Headers
headers
        TransferEncoding
Chunked -> Resource
-> Response -> Bytes -> M (Either Exception (Bodied Response))
handleChunkedBody Resource
ctx Response
resp Bytes
post

receiveResponseDiscardBody ::
  Resource ->
  M (Either Exception Response)
receiveResponseDiscardBody :: Resource -> M (Either Exception Response)
receiveResponseDiscardBody !Resource
ctx =
  Resource -> M (Either Exception (Response, Bytes))
receiveHeaders Resource
ctx M (Either Exception (Response, Bytes))
-> (Either Exception (Response, Bytes)
    -> M (Either Exception Response))
-> M (Either Exception Response)
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Exception
err -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left Exception
err)
    Right (resp :: Response
resp@Response.Response {Headers
$sel:headers:Response :: Response -> Headers
headers :: Headers
headers}, Bytes
post) -> case Headers -> Either HttpException TransferEncoding
lookupTransferEncoding Headers
headers of
      Left HttpException
err -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
err))
      Right TransferEncoding
enc -> case TransferEncoding
enc of
        TransferEncoding
Nonchunked -> Resource
-> Response -> Bytes -> Headers -> M (Either Exception Response)
discardNonchunkedBody Resource
ctx Response
resp Bytes
post Headers
headers
        TransferEncoding
Chunked -> Resource -> Response -> Bytes -> M (Either Exception Response)
discardChunkedBody Resource
ctx Response
resp Bytes
post

handleChunkedBody ::
  Resource ->
  Response ->
  Bytes ->
  M (Either Exception (Bodied Response))
handleChunkedBody :: Resource
-> Response -> Bytes -> M (Either Exception (Bodied Response))
handleChunkedBody !Resource
ctx Response
resp !Bytes
input0 = do
  let go :: Continuation -> Bytes -> M (Either Exception (Bodied Response))
go Continuation
contA !Bytes
inputA = case (forall s. Parser HttpException s Continuation)
-> Bytes -> Result HttpException Continuation
forall e a. (forall s. Parser e s a) -> Bytes -> Result e a
Parser.parseBytes (Continuation -> Parser HttpException s Continuation
forall s. Continuation -> Parser HttpException s Continuation
parserChunked Continuation
contA) Bytes
inputA of
        Parser.Failure HttpException
e -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
e))
        Parser.Success (Parser.Slice Int
_ Int
leftoverLen Continuation
contB) -> case Int
leftoverLen of
          -- We expect that parserChunked consumes all input, so we check
          -- here to be certain that it actually does.
          Int
0 -> case Continuation
contB of
            Continuation Instruction
Done Chunks
revChunks ->
              Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Exception (Bodied Response)
 -> M (Either Exception (Bodied Response)))
-> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a b. (a -> b) -> a -> b
$
                Bodied Response -> Either Exception (Bodied Response)
forall a b. b -> Either a b
Right (Bodied Response -> Either Exception (Bodied Response))
-> Bodied Response -> Either Exception (Bodied Response)
forall a b. (a -> b) -> a -> b
$
                  Bodied
                    { metadata :: Response
metadata = Response
resp
                    , body :: Chunks
body = Chunks -> Chunks
Chunks.reverse Chunks
revChunks
                    }
            Continuation
_ ->
              Resource -> M (Either ReceiveException Bytes)
receive Resource
ctx M (Either ReceiveException Bytes)
-> (Either ReceiveException Bytes
    -> M (Either Exception (Bodied Response)))
-> M (Either Exception (Bodied Response))
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Right Bytes
inputB -> case Bytes -> Int
Bytes.length Bytes
inputB of
                  Int
0 -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.ChunkedBodyEndOfInput))
                  Int
_ -> Continuation -> Bytes -> M (Either Exception (Bodied Response))
go Continuation
contB Bytes
inputB
                Left ReceiveException
err -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (ReceiveException -> Exception
Receive ReceiveException
err))
          Int
_ -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.ImplementationMistake))
  let cont0 :: Continuation
cont0 = Instruction -> Chunks -> Continuation
Continuation (Word64 -> Instruction
ChunkLength Word64
0) Chunks
ChunksNil
  Continuation -> Bytes -> M (Either Exception (Bodied Response))
go Continuation
cont0 Bytes
input0

parserChunked :: Continuation -> Parser HttpException s Continuation
parserChunked :: forall s. Continuation -> Parser HttpException s Continuation
parserChunked (Continuation Instruction
instr Chunks
chunks0) = case Instruction
instr of
  Instruction
Done -> HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.ImplementationMistake
  More Int
total Int
n -> Int -> Int -> Chunks -> Parser HttpException s Continuation
forall s.
Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore Int
total Int
n Chunks
chunks0
  MorePostCr Int
total -> Int -> Chunks -> Parser HttpException s Continuation
forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePostCr Int
total Chunks
chunks0
  ChunkLength Word64
acc -> Word64 -> Chunks -> Parser HttpException s Continuation
forall s. Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength Word64
acc Chunks
chunks0
  PostCr Int
n -> Int -> Chunks -> Parser HttpException s Continuation
forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLengthPostCr Int
n Chunks
chunks0

parserChunkedMore :: Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore :: forall s.
Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore !Int
total !Int
n !Chunks
chunks0 = case Int
n of
  -- If there are no more bytes left in the chunk, we start
  -- on the next decimal-encoded chunk length.
  Int
0 -> Int -> Chunks -> Parser HttpException s Continuation
forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePost Int
total Chunks
chunks0
  Int
_ -> do
    Bytes
b <- Int -> Parser HttpException s Bytes
forall e s. Int -> Parser e s Bytes
Parser.takeUpTo Int
n
    case Bytes -> Int
Bytes.length Bytes
b of
      -- If there was no input left, we return to request more input.
      -- If we didn't check for this, we would go into a loop.
      Int
0 -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation (Int -> Int -> Instruction
More Int
total Int
n) Chunks
chunks0)
      Int
m -> do
        let chunks1 :: Chunks
chunks1 = Bytes -> Chunks -> Chunks
ChunksCons Bytes
b Chunks
chunks0
        Int -> Int -> Chunks -> Parser HttpException s Continuation
forall s.
Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore Int
total (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Chunks
chunks1

parserChunkedMorePost :: Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePost :: forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePost !Int
total !Chunks
chunks0 =
  Parser HttpException s (Maybe Char)
forall e s. Parser e s (Maybe Char)
Latin.opt Parser HttpException s (Maybe Char)
-> (Maybe Char -> Parser HttpException s Continuation)
-> Parser HttpException s Continuation
forall a b.
Parser HttpException s a
-> (a -> Parser HttpException s b) -> Parser HttpException s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Char
'\r' -> Int -> Chunks -> Parser HttpException s Continuation
forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePostCr Int
total Chunks
chunks0
    Just Char
_ -> HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.ExpectedCrlfAfterChunk
    Maybe Char
Nothing -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation (Int -> Int -> Instruction
More Int
total Int
0) Chunks
chunks0)

parserChunkedMorePostCr :: Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePostCr :: forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMorePostCr !Int
total !Chunks
chunks0 =
  Parser HttpException s (Maybe Char)
forall e s. Parser e s (Maybe Char)
Latin.opt Parser HttpException s (Maybe Char)
-> (Maybe Char -> Parser HttpException s Continuation)
-> Parser HttpException s Continuation
forall a b.
Parser HttpException s a
-> (a -> Parser HttpException s b) -> Parser HttpException s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Char
'\n' -> case Int
total of
      Int
0 -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation Instruction
Done Chunks
chunks0)
      Int
_ -> Word64 -> Chunks -> Parser HttpException s Continuation
forall s. Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength Word64
0 Chunks
chunks0
    Just Char
_ -> HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.ExpectedCrlfAfterChunk
    Maybe Char
Nothing -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation (Int -> Instruction
MorePostCr Int
total) Chunks
chunks0)

parserChunkedChunkLength :: Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength :: forall s. Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength !Word64
acc !Chunks
chunks0 =
  if Word64
acc Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
100_000_000
    then HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.ChunkTooLarge
    else
      Parser HttpException s (Maybe Char)
forall e s. Parser e s (Maybe Char)
Latin.opt Parser HttpException s (Maybe Char)
-> (Maybe Char -> Parser HttpException s Continuation)
-> Parser HttpException s Continuation
forall a b.
Parser HttpException s a
-> (a -> Parser HttpException s b) -> Parser HttpException s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Char
Nothing -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation (Word64 -> Instruction
ChunkLength Word64
acc) Chunks
chunks0)
        Just Char
c -> case Char
c of
          Char
'\r' ->
            Parser HttpException s (Maybe Char)
forall e s. Parser e s (Maybe Char)
Latin.opt Parser HttpException s (Maybe Char)
-> (Maybe Char -> Parser HttpException s Continuation)
-> Parser HttpException s Continuation
forall a b.
Parser HttpException s a
-> (a -> Parser HttpException s b) -> Parser HttpException s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just Char
d -> case Char
d of
                Char
'\n' -> do
                  let !acc' :: Int
acc' = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
acc :: Int
                  Int -> Int -> Chunks -> Parser HttpException s Continuation
forall s.
Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore Int
acc' Int
acc' Chunks
chunks0
                Char
_ -> HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.ExpectedCrlfAfterChunkLength
              Maybe Char
Nothing -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation (Int -> Instruction
PostCr (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
acc)) Chunks
chunks0)
          Char
_ | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0', Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' -> Word64 -> Chunks -> Parser HttpException s Continuation
forall s. Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength (Word64
acc Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
16 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x30)) Chunks
chunks0
          Char
_ | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a', Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' -> Word64 -> Chunks -> Parser HttpException s Continuation
forall s. Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength (Word64
acc Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
16 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
0x61 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10))) Chunks
chunks0
          Char
_ | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A', Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' -> Word64 -> Chunks -> Parser HttpException s Continuation
forall s. Word64 -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLength (Word64
acc Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
16 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
0x41 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10))) Chunks
chunks0
          Char
_ -> HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.NonNumericChunkLength

parserChunkedChunkLengthPostCr :: Int -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLengthPostCr :: forall s. Int -> Chunks -> Parser HttpException s Continuation
parserChunkedChunkLengthPostCr !Int
n !Chunks
chunks0 =
  Parser HttpException s (Maybe Char)
forall e s. Parser e s (Maybe Char)
Latin.opt Parser HttpException s (Maybe Char)
-> (Maybe Char -> Parser HttpException s Continuation)
-> Parser HttpException s Continuation
forall a b.
Parser HttpException s a
-> (a -> Parser HttpException s b) -> Parser HttpException s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Char
d -> case Char
d of
      Char
'\n' -> Int -> Int -> Chunks -> Parser HttpException s Continuation
forall s.
Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore Int
n Int
n Chunks
chunks0
      Char
_ -> HttpException -> Parser HttpException s Continuation
forall e s a. e -> Parser e s a
Parser.fail HttpException
E.ExpectedCrlfAfterChunkLength
    Maybe Char
Nothing -> Continuation -> Parser HttpException s Continuation
forall a. a -> Parser HttpException s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction -> Chunks -> Continuation
Continuation (Int -> Instruction
PostCr Int
n) Chunks
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 :: Resource
-> Response
-> Bytes
-> Headers
-> M (Either Exception (Bodied Response))
handleNonchunkedBody Resource
ctx Response
resp !Bytes
post !Headers
headers = case Headers -> Either HttpException Int
lookupContentLength Headers
headers of
  Left HttpException
err -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
err))
  Right Int
len -> do
    let finish :: Chunks -> Int -> M (Either Exception (Bodied Response))
finish Chunks
reversedChunks Int
n = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
0 of
          Ordering
LT -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.PipelinedResponses))
          Ordering
EQ ->
            Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Exception (Bodied Response)
 -> M (Either Exception (Bodied Response)))
-> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a b. (a -> b) -> a -> b
$
              Bodied Response -> Either Exception (Bodied Response)
forall a b. b -> Either a b
Right (Bodied Response -> Either Exception (Bodied Response))
-> Bodied Response -> Either Exception (Bodied Response)
forall a b. (a -> b) -> a -> b
$
                Bodied
                  { metadata :: Response
metadata = Response
resp
                  , body :: Chunks
body = Chunks -> Chunks
Chunks.reverse Chunks
reversedChunks
                  }
          Ordering
GT ->
            Resource -> M (Either ReceiveException Bytes)
receive Resource
ctx M (Either ReceiveException Bytes)
-> (Either ReceiveException Bytes
    -> M (Either Exception (Bodied Response)))
-> M (Either Exception (Bodied Response))
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right Bytes
chunk -> case Bytes -> Int
Bytes.length Bytes
chunk of
                Int
0 -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.NonchunkedBodyEndOfInput))
                Int
_ -> Chunks -> Int -> M (Either Exception (Bodied Response))
finish (Bytes -> Chunks -> Chunks
ChunksCons Bytes
chunk Chunks
reversedChunks) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bytes -> Int
Bytes.length Bytes
chunk)
              Left ReceiveException
err -> Either Exception (Bodied Response)
-> M (Either Exception (Bodied Response))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception (Bodied Response)
forall a b. a -> Either a b
Left (ReceiveException -> Exception
Receive ReceiveException
err))
    Chunks -> Int -> M (Either Exception (Bodied Response))
finish (Bytes -> Chunks -> Chunks
ChunksCons Bytes
post Chunks
ChunksNil) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bytes -> Int
Bytes.length Bytes
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 :: Resource
-> Response -> Bytes -> Headers -> M (Either Exception Response)
discardNonchunkedBody Resource
ctx Response
resp !Bytes
post !Headers
headers = case Headers -> Either HttpException Int
lookupContentLength Headers
headers of
  Left HttpException
err -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
err))
  Right Int
len -> do
    let finish :: Int -> M (Either Exception Response)
finish Int
n = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
0 of
          Ordering
LT -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.PipelinedResponses))
          Ordering
EQ -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Exception Response -> M (Either Exception Response))
-> Either Exception Response -> M (Either Exception Response)
forall a b. (a -> b) -> a -> b
$ Response -> Either Exception Response
forall a b. b -> Either a b
Right (Response -> Either Exception Response)
-> Response -> Either Exception Response
forall a b. (a -> b) -> a -> b
$ Response
resp
          Ordering
GT ->
            Resource -> M (Either ReceiveException Bytes)
receive Resource
ctx M (Either ReceiveException Bytes)
-> (Either ReceiveException Bytes -> M (Either Exception Response))
-> M (Either Exception Response)
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right Bytes
chunk -> case Bytes -> Int
Bytes.length Bytes
chunk of
                Int
0 -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.NonchunkedBodyEndOfInput))
                Int
_ -> Int -> M (Either Exception Response)
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bytes -> Int
Bytes.length Bytes
chunk)
              Left ReceiveException
err -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (ReceiveException -> Exception
Receive ReceiveException
err))
    Int -> M (Either Exception Response)
finish (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bytes -> Int
Bytes.length Bytes
post)

splitEndOfHeaders :: Bytes -> Maybe (Bytes, Bytes)
splitEndOfHeaders :: Bytes -> Maybe (Bytes, Bytes)
splitEndOfHeaders !Bytes
b = case Word8 -> Word8 -> Word8 -> Word8 -> Bytes -> Maybe Int
Bytes.findTetragramIndex Word8
0x0D Word8
0x0A Word8
0x0D Word8
0x0A Bytes
b of
  Maybe Int
Nothing -> Maybe (Bytes, Bytes)
forall a. Maybe a
Nothing
  Just Int
n -> (Bytes, Bytes) -> Maybe (Bytes, Bytes)
forall a. a -> Maybe a
Just (Int -> Bytes -> Bytes
Bytes.unsafeTake (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Bytes
b, Int -> Bytes -> Bytes
Bytes.unsafeDrop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Bytes
b)

lookupTransferEncoding :: Headers -> Either HttpException TransferEncoding
lookupTransferEncoding :: Headers -> Either HttpException TransferEncoding
lookupTransferEncoding !Headers
hdrs =
  case Headers -> Either LookupException Header
Headers.lookupTransferEncoding Headers
hdrs of
    Right Header {Text
value :: Text
value :: Header -> Text
value} -> case Text
value of
      Text
"chunked" -> TransferEncoding -> Either HttpException TransferEncoding
forall a b. b -> Either a b
Right TransferEncoding
Chunked
      Text
_ -> HttpException -> Either HttpException TransferEncoding
forall a b. a -> Either a b
Left HttpException
E.TransferEncodingUnrecognized
    Left LookupException
Missing -> TransferEncoding -> Either HttpException TransferEncoding
forall a b. b -> Either a b
Right TransferEncoding
Nonchunked
    Left LookupException
Duplicate -> HttpException -> Either HttpException TransferEncoding
forall a b. a -> Either a b
Left HttpException
E.TransferEncodingDuplicated

lookupContentLength :: Headers -> Either HttpException Int
lookupContentLength :: Headers -> Either HttpException Int
lookupContentLength !Headers
hdrs =
  case Headers -> Either LookupException Header
Headers.lookupContentLength Headers
hdrs of
    Left LookupException
Missing -> Int -> Either HttpException Int
forall a b. b -> Either a b
Right Int
0
    Left LookupException
Duplicate -> HttpException -> Either HttpException Int
forall a b. a -> Either a b
Left HttpException
E.ContentLengthDuplicated
    Right Header {Text
value :: Header -> Text
value :: Text
value} -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
value) of
      Maybe Int
Nothing -> HttpException -> Either HttpException Int
forall a b. a -> Either a b
Left HttpException
E.ContentLengthMalformed
      Just Int
i -> do
        Bool -> Either HttpException () -> Either HttpException ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8_000_000_000) (HttpException -> Either HttpException ()
forall a b. a -> Either a b
Left HttpException
E.ContentLengthTooLarge)
        Int -> Either HttpException Int
forall a b. b -> Either a b
Right Int
i

discardChunkedBody ::
  Resource ->
  Response ->
  Bytes ->
  M (Either Exception Response)
discardChunkedBody :: Resource -> Response -> Bytes -> M (Either Exception Response)
discardChunkedBody !Resource
ctx Response
resp !Bytes
input0 = do
  let go :: Instruction -> Bytes -> M (Either Exception Response)
      go :: Instruction -> Bytes -> M (Either Exception Response)
go Instruction
instrA !Bytes
inputA = case (forall s. Parser HttpException s Continuation)
-> Bytes -> Result HttpException Continuation
forall e a. (forall s. Parser e s a) -> Bytes -> Result e a
Parser.parseBytes (Continuation -> Parser HttpException s Continuation
forall s. Continuation -> Parser HttpException s Continuation
parserChunked (Instruction -> Continuation
upgradeInstruction Instruction
instrA)) Bytes
inputA of
        Parser.Failure HttpException
e -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
e))
        Parser.Success (Parser.Slice Int
_ Int
leftoverLen Continuation
contB) ->
          let instrB :: Instruction
instrB = Continuation -> Instruction
downgradeContinuation Continuation
contB
           in case Int
leftoverLen of
                -- We expect that parserChunked consumes all input, so we check
                -- here to be certain that it actually does.
                Int
0 -> case Instruction
instrB of
                  Instruction
Done -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Exception Response -> M (Either Exception Response))
-> Either Exception Response -> M (Either Exception Response)
forall a b. (a -> b) -> a -> b
$ Response -> Either Exception Response
forall a b. b -> Either a b
Right (Response -> Either Exception Response)
-> Response -> Either Exception Response
forall a b. (a -> b) -> a -> b
$ Response
resp
                  Instruction
_ ->
                    Resource -> M (Either ReceiveException Bytes)
receive Resource
ctx M (Either ReceiveException Bytes)
-> (Either ReceiveException Bytes -> M (Either Exception Response))
-> M (Either Exception Response)
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Right Bytes
inputB -> case Bytes -> Int
Bytes.length Bytes
inputB of
                        Int
0 -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.ChunkedBodyEndOfInput))
                        Int
_ -> Instruction -> Bytes -> M (Either Exception Response)
go Instruction
instrB Bytes
inputB
                      Left ReceiveException
err -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (ReceiveException -> Exception
Receive ReceiveException
err))
                Int
_ -> Either Exception Response -> M (Either Exception Response)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception Response
forall a b. a -> Either a b
Left (HttpException -> Exception
Http HttpException
E.ImplementationMistake))
  let instr0 :: Instruction
instr0 = Word64 -> Instruction
ChunkLength Word64
0
  Instruction -> Bytes -> M (Either Exception Response)
go Instruction
instr0 Bytes
input0

upgradeInstruction :: Instruction -> Continuation
upgradeInstruction :: Instruction -> Continuation
upgradeInstruction Instruction
i = Instruction -> Chunks -> Continuation
Continuation Instruction
i Chunks
ChunksNil

downgradeContinuation :: Continuation -> Instruction
downgradeContinuation :: Continuation -> Instruction
downgradeContinuation (Continuation Instruction
i Chunks
_) = Instruction
i