{-# 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
data Instruction
= More
!Int
!Int
| MorePostCr
!Int
| ChunkLength
!Word64
| PostCr
!Int
|
Done
data TransferEncoding
= Nonchunked
| Chunked
data Exception
=
Http
!HttpException
|
Send
!SendException
|
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)
exchangeDiscardBody ::
Resource ->
Bodied Request ->
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
exchange ::
Resource ->
Bodied Request ->
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
receiveHeaders ::
Resource ->
M (Either Exception (Response, Bytes))
!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
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
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
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)
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)
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)
!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
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