{-# language DeriveAnyClass #-}
{-# language DerivingStrategies #-}
{-# language DuplicateRecordFields #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
module Exchange
( Exception(..)
, HttpException(..)
, exchange
) where
import Channel (M,Resource,SendException,ReceiveException,send,receive)
import Control.Monad (when)
import Data.Char (ord)
import Data.Bytes (Bytes)
import Data.Bytes.Chunks (Chunks(ChunksCons,ChunksNil))
import Data.Word (Word64)
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 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
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
| Done
-- ^ We got all the chunks, and we got the zero-length chunk
-- at the end, and we got the trailing CRLF. We are done.
data TransferEncoding
= Nonchunked
| Chunked
-- | An exception that occurs during an HTTP exchange.
data Exception
= Http -- ^ The response was not a valid HTTP response
!HttpException
| Send
-- ^ Transport exception while sending. When backed by stream sockets,
-- exceptions like @ECONNRESET@ show up here.
!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.
!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)
-- | 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 ctx req = do
let enc = Request.bodiedToChunks req
send ctx enc >>= \case
Left err -> pure (Left (Send err))
Right () -> receiveResponse 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
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
handleChunkedBody ::
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))
Parser.Success (Parser.Slice _ leftoverLen contB) -> case leftoverLen of
-- 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))
_ -> pure (Left (Http E.ImplementationMistake))
let cont0 = Continuation (ChunkLength 0) ChunksNil
go cont0 input0
parserChunked :: Continuation -> Parser HttpException s Continuation
parserChunked (Continuation instr chunks0) = case instr of
Done -> Parser.fail E.ImplementationMistake
More total n -> parserChunkedMore total n chunks0
MorePostCr total -> parserChunkedMorePostCr total chunks0
ChunkLength acc -> parserChunkedChunkLength acc chunks0
PostCr n -> parserChunkedChunkLengthPostCr n chunks0
parserChunkedMore :: Int -> Int -> Chunks -> Parser HttpException s Continuation
parserChunkedMore !total !n !chunks0 = case n of
-- If there are no more bytes left in the chunk, we start
-- on the next decimal-encoded chunk length.
0 -> parserChunkedMorePost total chunks0
_ -> do
b <- Parser.takeUpTo n
case Bytes.length 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.
0 -> pure (Continuation (More total n) chunks0)
m -> do
let chunks1 = ChunksCons b chunks0
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)
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)
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
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)
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))
finish (ChunksCons post ChunksNil) (len - Bytes.length post)
splitEndOfHeaders :: Bytes -> Maybe (Bytes, Bytes)
splitEndOfHeaders !b = case Bytes.findTetragramIndex 0x0D 0x0A 0x0D 0x0A b of
Nothing -> Nothing
Just n -> Just (Bytes.unsafeTake (n + 4) b, Bytes.unsafeDrop (n + 4) b)
lookupTransferEncoding :: Headers -> Either HttpException TransferEncoding
lookupTransferEncoding !hdrs =
case Headers.lookupTransferEncoding hdrs of
Right Header{value} -> case value of
"chunked" -> Right Chunked
_ -> Left E.TransferEncodingUnrecognized
Left Missing -> Right Nonchunked
Left Duplicate -> Left E.TransferEncodingDuplicated
lookupContentLength :: Headers -> Either HttpException Int
lookupContentLength !hdrs =
case Headers.lookupContentLength hdrs of
Left Missing -> Right 0
Left Duplicate -> Left E.ContentLengthDuplicated
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