{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.HTTP2.H2.Receiver (
    frameReceiver,
    closureClient,
    closureServer,
    sendPing,
) where

import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Short as Short
import qualified Data.ByteString.UTF8 as UTF8
import Data.IORef
import Data.Void
import Network.Control
import Network.HTTP.Semantics
import qualified System.IO.Error as E
import qualified System.ThreadManager as T
import qualified System.TimeManager as TM

import Imports hiding (delete, insert)
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.EncodeFrame
import Network.HTTP2.H2.HPACK
import Network.HTTP2.H2.Queue
import Network.HTTP2.H2.Settings
import Network.HTTP2.H2.Stream
import Network.HTTP2.H2.StreamTable
import Network.HTTP2.H2.Types
import Network.HTTP2.H2.Window

----------------------------------------------------------------

continuationLimit :: Int
continuationLimit :: Int
continuationLimit = Int
10

headerFragmentLimit :: Int
headerFragmentLimit :: Int
headerFragmentLimit = Int
51200 -- 50K

----------------------------------------------------------------

frameReceiver :: Context -> Config -> IO E.SomeException
frameReceiver :: Context -> Config -> IO SomeException
frameReceiver ctx :: Context
ctx@Context{TVar (Maybe SomeException)
receiverDone :: TVar (Maybe SomeException)
receiverDone :: Context -> TVar (Maybe SomeException)
receiverDone} conf :: Config
conf@Config{Bool
Int
Buffer
SockAddr
Manager
Int -> IO ByteString
Int -> TokenHeaderTable -> IO ()
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confReadNTimeout :: Bool
confOnInformational :: Int -> TokenHeaderTable -> IO ()
confOnInformational :: Config -> Int -> TokenHeaderTable -> IO ()
confReadNTimeout :: Config -> Bool
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} =
    ((forall a. IO a -> IO a) -> IO SomeException) -> IO SomeException
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO SomeException)
 -> IO SomeException)
-> ((forall a. IO a -> IO a) -> IO SomeException)
-> IO SomeException
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
        -- This catches an asynchronous exception.
        -- It is re-thrown by "runH2"
        Either SomeException Void
mErr <- IO Void -> IO (Either SomeException Void)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO Void -> IO (Either SomeException Void))
-> IO Void -> IO (Either SomeException Void)
forall a b. (a -> b) -> a -> b
$ IO Void -> IO Void
forall a. IO a -> IO a
unmask IO Void
switch
        case Either SomeException Void
mErr of
            Left SomeException
err -> do
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe SomeException) -> Maybe SomeException -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe SomeException)
receiverDone (Maybe SomeException -> STM ()) -> Maybe SomeException -> STM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
err
                SomeException -> IO SomeException
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SomeException
err
            Right Void
x -> do
                Void -> IO SomeException
forall a. Void -> a
absurd Void
x -- We only terminate due to exceptions
  where
    switch :: IO Void
    switch :: IO Void
switch = do
        [Char] -> IO ()
labelMe [Char]
"H2 receiver"
        ThreadId
tid <- IO ThreadId
myThreadId
        if Bool
confReadNTimeout
            then
                IO Void
loop1
            else
                Manager -> IO () -> (Handle -> IO Void) -> IO Void
forall a. Manager -> IO () -> (Handle -> IO a) -> IO a
TM.withHandle (Context -> Manager
timeoutManager Context
ctx) (ThreadId -> HTTP2Error -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
E.throwTo ThreadId
tid HTTP2Error
ConnectionIsTimeout) Handle -> IO Void
loop2

    loop1 :: IO Void
    loop1 :: IO Void
loop1 = do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ControlQ -> STM ()
waitControlQ (ControlQ -> STM ()) -> ControlQ -> STM ()
forall a b. (a -> b) -> a -> b
$ Context -> ControlQ
controlQ Context
ctx
        ByteString
hd <- Int -> IO ByteString
confReadN Int
frameHeaderLength -- throwing an exception on timeout
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
hd) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
ConnectionIsClosed
        Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
conf ((FrameType, FrameHeader) -> IO ())
-> (FrameType, FrameHeader) -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (FrameType, FrameHeader)
decodeFrameHeader ByteString
hd
        IO Void
loop1

    loop2 :: TM.Handle -> IO Void
    loop2 :: Handle -> IO Void
loop2 Handle
th = do
        -- If 'confReadN' is timeouted, 'ConnectionIsTimeout' is thrown
        -- to destroy the thread trees.  So it is if the peer does not
        -- read what we send, and we wait here for ever.
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ControlQ -> STM ()
waitControlQ (ControlQ -> STM ()) -> ControlQ -> STM ()
forall a b. (a -> b) -> a -> b
$ Context -> ControlQ
controlQ Context
ctx
        ByteString
hd <- Int -> IO ByteString
confReadN Int
frameHeaderLength
        Handle -> IO ()
TM.tickle Handle
th
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
hd) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
ConnectionIsClosed
        Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
conf ((FrameType, FrameHeader) -> IO ())
-> (FrameType, FrameHeader) -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (FrameType, FrameHeader)
decodeFrameHeader ByteString
hd
        Handle -> IO Void
loop2 Handle
th

----------------------------------------------------------------

processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
_conf (FrameType
fid, FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId})
    | Context -> Bool
isServer Context
ctx
        Bool -> Bool -> Bool
&& Int -> Bool
isServerInitiated Int
streamId
        Bool -> Bool -> Bool
&& (FrameType
fid FrameType -> [FrameType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameType
FramePriority, FrameType
FrameRSTStream, FrameType
FrameWindowUpdate]) =
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"stream id should be odd"
processFrame Context
ctx Config
_conf (FrameType
FramePushPromise, FrameHeader{Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId})
    | Context -> Bool
isServer Context
ctx =
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"push promise is not allowed"
processFrame Context{TVar Int
TVar (Maybe Int)
TVar (Maybe SomeException)
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe HeaderContinuation)
IORef IntSet
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Output
Manager
ThreadManager
DynamicTable
Settings
ControlQ
RoleInfo
Role
Int -> TokenHeaderTable -> IO ()
receiverDone :: Context -> TVar (Maybe SomeException)
timeoutManager :: Context -> Manager
controlQ :: Context -> ControlQ
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe HeaderContinuation)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: ControlQ
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
timeoutManager :: Manager
receiverDone :: TVar (Maybe SomeException)
appDone :: STM Bool
informationalCallback :: Int -> TokenHeaderTable -> IO ()
peerGoAway :: TVar (Maybe Int)
activeRequests :: TVar Int
resetByMe :: IORef IntSet
resetByMe :: Context -> IORef IntSet
activeRequests :: Context -> TVar Int
peerGoAway :: Context -> TVar (Maybe Int)
informationalCallback :: Context -> Int -> TokenHeaderTable -> IO ()
appDone :: Context -> STM Bool
threadManager :: Context -> ThreadManager
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerLastStreamId :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe HeaderContinuation)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Config
conf (FrameType
ftyp, FrameHeader{Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId})
    | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Ord a => a -> a -> Bool
> FrameType
maxFrameType = do
        Maybe HeaderContinuation
mx <- IORef (Maybe HeaderContinuation) -> IO (Maybe HeaderContinuation)
forall a. IORef a -> IO a
readIORef IORef (Maybe HeaderContinuation)
continued
        case Maybe HeaderContinuation
mx of
            Maybe HeaderContinuation
Nothing -> do
                -- ignoring unknown frame
                IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Int -> IO ByteString
readPayload Config
conf Int
payloadLength
            Just HeaderContinuation
_ -> HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"unknown frame"
processFrame ctx :: Context
ctx@Context{TVar Int
TVar (Maybe Int)
TVar (Maybe SomeException)
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe HeaderContinuation)
IORef IntSet
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Output
Manager
ThreadManager
DynamicTable
Settings
ControlQ
RoleInfo
Role
Int -> TokenHeaderTable -> IO ()
receiverDone :: Context -> TVar (Maybe SomeException)
timeoutManager :: Context -> Manager
controlQ :: Context -> ControlQ
resetByMe :: Context -> IORef IntSet
activeRequests :: Context -> TVar Int
peerGoAway :: Context -> TVar (Maybe Int)
informationalCallback :: Context -> Int -> TokenHeaderTable -> IO ()
appDone :: Context -> STM Bool
threadManager :: Context -> ThreadManager
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerLastStreamId :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe HeaderContinuation)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe HeaderContinuation)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: ControlQ
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
timeoutManager :: Manager
receiverDone :: TVar (Maybe SomeException)
appDone :: STM Bool
informationalCallback :: Int -> TokenHeaderTable -> IO ()
peerGoAway :: TVar (Maybe Int)
activeRequests :: TVar Int
resetByMe :: IORef IntSet
..} Config
conf typhdr :: (FrameType, FrameHeader)
typhdr@(FrameType
ftyp, FrameHeader
header) = do
    -- My SETTINGS_MAX_FRAME_SIZE
    -- My SETTINGS_ENABLE_PUSH
    case (FrameType, FrameHeader)
-> Either FrameDecodeError (FrameType, FrameHeader)
checkFrameHeader (FrameType, FrameHeader)
typhdr of
        Left (FrameDecodeError ErrorCode
ec Int
sid ReasonPhrase
msg) -> HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec Int
sid ReasonPhrase
msg
        Right (FrameType, FrameHeader)
_ -> do
            let Settings{Int
maxFrameSize :: Int
maxFrameSize :: Settings -> Int
maxFrameSize, Bool
enablePush :: Bool
enablePush :: Settings -> Bool
enablePush} = Settings
mySettings
                sid :: Int
sid = FrameHeader -> Int
streamId FrameHeader
header
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameHeader -> Int
payloadLength FrameHeader
header Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxFrameSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError Int
sid ReasonPhrase
"exceeds maximum frame size"
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
enablePush Bool -> Bool -> Bool
&& FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
sid ReasonPhrase
"push not enabled"
            Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream Context
ctx Config
conf FrameType
ftyp FrameHeader
header

----------------------------------------------------------------

-- | Read a frame payload in full.
--
-- 'confReadN' answers with an empty string at end of input, so a payload that
-- comes back short means the peer hung up in the middle of the frame.  Saying
-- so here keeps every decoder below from being handed fewer bytes than the
-- frame header promised it.
readPayload :: Config -> Int -> IO ByteString
readPayload :: Config -> Int -> IO ByteString
readPayload Config{Bool
Int
Buffer
SockAddr
Manager
Int -> IO ByteString
Int -> TokenHeaderTable -> IO ()
PositionReadMaker
ByteString -> IO ()
confOnInformational :: Config -> Int -> TokenHeaderTable -> IO ()
confReadNTimeout :: Config -> Bool
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confReadNTimeout :: Bool
confOnInformational :: Int -> TokenHeaderTable -> IO ()
..} Int
len = do
    ByteString
bs <- Int -> IO ByteString
confReadN Int
len
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
ConnectionIsClosed
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream ctx :: Context
ctx@Context{TVar Int
TVar (Maybe Int)
TVar (Maybe SomeException)
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe HeaderContinuation)
IORef IntSet
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Output
Manager
ThreadManager
DynamicTable
Settings
ControlQ
RoleInfo
Role
Int -> TokenHeaderTable -> IO ()
receiverDone :: Context -> TVar (Maybe SomeException)
timeoutManager :: Context -> Manager
controlQ :: Context -> ControlQ
resetByMe :: Context -> IORef IntSet
activeRequests :: Context -> TVar Int
peerGoAway :: Context -> TVar (Maybe Int)
informationalCallback :: Context -> Int -> TokenHeaderTable -> IO ()
appDone :: Context -> STM Bool
threadManager :: Context -> ThreadManager
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerLastStreamId :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe HeaderContinuation)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe HeaderContinuation)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: ControlQ
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
timeoutManager :: Manager
receiverDone :: TVar (Maybe SomeException)
appDone :: STM Bool
informationalCallback :: Int -> TokenHeaderTable -> IO ()
peerGoAway :: TVar (Maybe Int)
activeRequests :: TVar Int
resetByMe :: IORef IntSet
..} Config
conf FrameType
ftyp header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId, Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength}
    | Int -> Bool
isControl Int
streamId = do
        ByteString
bs <- Config -> Int -> IO ByteString
readPayload Config
conf Int
payloadLength
        FrameType -> FrameHeader -> ByteString -> Context -> IO ()
control FrameType
ftyp FrameHeader
header ByteString
bs Context
ctx
    | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise = do
        ByteString
bs <- Config -> Int -> IO ByteString
readPayload Config
conf Int
payloadLength
        -- A promised stream can be refused over concurrency too, and by the
        -- time 'push' gets that far it has decoded the field block, so the
        -- same reasoning as 'resettable' applies: reset the promised stream
        -- and read on.  There is no 'Stream' to close -- it was refused
        -- before one was made -- so this resets by identifier alone.
        FrameHeader -> ByteString -> Context -> IO ()
push FrameHeader
header ByteString
bs Context
ctx IO () -> (HTTP2Error -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` HTTP2Error -> IO ()
resetPromised
    | Bool
otherwise = do
        Maybe HeaderContinuation
mcont <- IO (Maybe HeaderContinuation)
checkContinued
        Maybe Stream
mstrm <- Context -> FrameType -> Int -> IO (Maybe Stream)
getStream Context
ctx FrameType
ftyp Int
streamId
        ByteString
bs <- Config -> Int -> IO ByteString
readPayload Config
conf Int
payloadLength
        case Maybe HeaderContinuation
mcont of
            Just HeaderContinuation
hc -> HeaderContinuation -> ByteString -> Maybe Stream -> IO ()
continuation HeaderContinuation
hc ByteString
bs Maybe Stream
mstrm
            Maybe HeaderContinuation
Nothing ->
                case Maybe Stream
mstrm of
                    Just Stream
strm -> Stream -> IO () -> IO ()
resettable Stream
strm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        StreamState
state0 <- Stream -> IO StreamState
readStreamState Stream
strm
                        StreamState
state <- FrameType
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameType
ftyp FrameHeader
header ByteString
bs Context
ctx StreamState
state0 Stream
strm
                        StreamState -> Context -> Stream -> Int -> IO ()
processState StreamState
state Context
ctx Stream
strm Int
streamId
                    Maybe Stream
Nothing
                        | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePriority -> do
                            -- for h2spec only
                            PriorityFrame Priority
newpri <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
                            Priority -> Int -> IO ()
checkPriority Priority
newpri Int
streamId
                        | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameData ->
                            -- Dropped, but still paid for.
                            Context -> Int -> Int -> IO ()
informIgnoredData Context
ctx Int
streamId Int
payloadLength
                        | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders -> do
                            HeadersFrame Maybe Priority
_ ByteString
frag <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
                            if FrameFlags -> Bool
testEndHeader FrameFlags
flags
                                then ByteString -> Int -> Context -> IO ()
hpackDiscardHeader ByteString
frag Int
streamId Context
ctx
                                else Context -> Int -> Bool -> ByteString -> IO ()
startHeaderBlock Context
ctx Int
streamId (FrameFlags -> Bool
testEndStream FrameFlags
flags) ByteString
frag
                        | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    resetContinued :: IO ()
resetContinued = IORef (Maybe HeaderContinuation)
-> Maybe HeaderContinuation -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe HeaderContinuation)
continued Maybe HeaderContinuation
forall a. Maybe a
Nothing
    resetPromised :: HTTP2Error -> IO ()
resetPromised (StreamErrorIsSent ErrorCode
err Int
sid ReasonPhrase
_msg) =
        ControlQ -> Control -> IO ()
enqueueControl ControlQ
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ErrorCode -> Int -> ByteString
resetFrame ErrorCode
err Int
sid]
    resetPromised HTTP2Error
e = HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
    -- Answer a stream error by resetting that stream and reading on, which is
    -- what RFC 9113 section 5.4.2 asks for: "an error related to a specific
    -- stream that does not affect processing of other streams".
    --
    -- Safe only here, after the payload has been read and any field block in
    -- it decoded, so that the connection sits at a frame boundary and the
    -- HPACK tables still agree with the peer's.  Where neither holds -- a
    -- field block abandoned part-way, a stream refused before its payload was
    -- read -- the error is raised as a connection error where it is detected,
    -- and travels straight past this handler.
    resettable :: Stream -> IO () -> IO ()
resettable Stream
strm IO ()
act = IO ()
act IO () -> (HTTP2Error -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` HTTP2Error -> IO ()
reset
      where
        reset :: HTTP2Error -> IO ()
reset e :: HTTP2Error
e@(StreamErrorIsSent ErrorCode
err Int
sid ReasonPhrase
_msg) = do
            -- MadeYouReset: CVE-2025-8671.  A reset we send because of
            -- what the peer sent frees the stream's concurrency slot just as
            -- one the peer sends does, while a handler already launched for
            -- the stream runs on.  Counted with the peer's own resets, or a
            -- peer that never sends RST_STREAM -- a PRIORITY on the stream
            -- depending on itself is enough -- could keep any number of
            -- handlers running past SETTINGS_MAX_CONCURRENT_STREAMS.
            --
            -- REFUSED_STREAM is left out: it launches nothing, and it is the
            -- answer section 8.7 means a peer to be able to retry.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ErrorCode
err ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ErrorCode
RefusedStream) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Int
rate <- Rate -> IO Int
getRate Rate
rstRate
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
rstRateLimit Settings
mySettings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
sid ReasonPhrase
"too many stream errors"
            IO ()
resetContinued
            -- 'closed' hands the exception to whoever is reading the stream
            -- and takes it out of the stream table.
            Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm (ClosedCode -> IO ()) -> ClosedCode -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> ClosedCode
ResetByMe (SomeException -> ClosedCode) -> SomeException -> ClosedCode
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> SomeException
forall e. Exception e => e -> SomeException
E.toException HTTP2Error
e
            ControlQ -> Control -> IO ()
enqueueControl ControlQ
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ErrorCode -> Int -> ByteString
resetFrame ErrorCode
err Int
sid]
        reset HTTP2Error
e = HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e

    checkContinued :: IO (Maybe HeaderContinuation)
    checkContinued :: IO (Maybe HeaderContinuation)
checkContinued = do
        Maybe HeaderContinuation
mx <- IORef (Maybe HeaderContinuation) -> IO (Maybe HeaderContinuation)
forall a. IORef a -> IO a
readIORef IORef (Maybe HeaderContinuation)
continued
        case Maybe HeaderContinuation
mx of
            Maybe HeaderContinuation
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just HeaderContinuation
hc
                | HeaderContinuation -> Int
hcStreamId HeaderContinuation
hc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
streamId Bool -> Bool -> Bool
&& FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameContinuation -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise ->
                    HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"continuation frame must follow"
        Maybe HeaderContinuation -> IO (Maybe HeaderContinuation)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HeaderContinuation
mx

    continuation
        :: HeaderContinuation -> HeaderBlockFragment -> Maybe Stream -> IO ()
    continuation :: HeaderContinuation -> ByteString -> Maybe Stream -> IO ()
continuation HeaderContinuation
hc ByteString
frag Maybe Stream
mstrm
        | ByteString
frag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not (FrameFlags -> Bool
testEndHeader FrameFlags
flags) = do
            -- Empty Frame Flooding - CVE-2019-9518
            Int
rate <- Rate -> IO Int
getRate Rate
emptyFrameRate
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
emptyFrameRateLimit Settings
mySettings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many empty continuation"
        | Bool
otherwise = do
            PartialHeaderBlock
phb' <- Int -> ByteString -> PartialHeaderBlock -> IO PartialHeaderBlock
addFragment Int
streamId ByteString
frag (HeaderContinuation -> PartialHeaderBlock
hcBlock HeaderContinuation
hc)
            if FrameFlags -> Bool
testEndHeader FrameFlags
flags
                then HeaderContinuation -> ByteString -> Maybe Stream -> IO ()
completeBlock HeaderContinuation
hc (PartialHeaderBlock -> ByteString
completeHeaderBlock PartialHeaderBlock
phb') Maybe Stream
mstrm
                else IORef (Maybe HeaderContinuation)
-> Maybe HeaderContinuation -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe HeaderContinuation)
continued (Maybe HeaderContinuation -> IO ())
-> Maybe HeaderContinuation -> IO ()
forall a b. (a -> b) -> a -> b
$ HeaderContinuation -> Maybe HeaderContinuation
forall a. a -> Maybe a
Just HeaderContinuation
hc{hcBlock = phb'}

    completeBlock
        :: HeaderContinuation -> HeaderBlockFragment -> Maybe Stream -> IO ()
    completeBlock :: HeaderContinuation -> ByteString -> Maybe Stream -> IO ()
completeBlock HeaderContinuation
hc ByteString
blk Maybe Stream
mstrm = do
        IO ()
resetContinued
        case Maybe Stream
mstrm of
            Just Stream
strm -> Stream -> IO () -> IO ()
resettable Stream
strm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                StreamState
state0 <- Stream -> IO StreamState
readStreamState Stream
strm
                case StreamState
state0 of
                    Open Maybe ClosedCode
hcl OpenState
JustOpened -> do
                        TokenHeaderTable
tbl <- ByteString -> Int -> Context -> IO TokenHeaderTable
hpackDecodeHeader ByteString
blk Int
streamId Context
ctx
                        StreamState
state <- Context
-> Int
-> Maybe ClosedCode
-> Bool
-> TokenHeaderTable
-> IO StreamState
onResponseHeaders Context
ctx Int
streamId Maybe ClosedCode
hcl (HeaderContinuation -> Bool
hcEndOfStream HeaderContinuation
hc) TokenHeaderTable
tbl
                        StreamState -> Context -> Stream -> Int -> IO ()
processState StreamState
state Context
ctx Stream
strm Int
streamId
                    Open Maybe ClosedCode
_ (Body TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
tlr) -> do
                        StreamState
state <- Context
-> Int
-> ByteString
-> TQueue (Either SomeException (ByteString, Bool))
-> Maybe Int
-> IORef Int
-> IORef (Maybe TokenHeaderTable)
-> IO StreamState
onTrailers Context
ctx Int
streamId ByteString
blk TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
tlr
                        StreamState -> Context -> Stream -> Int -> IO ()
processState StreamState
state Context
ctx Stream
strm Int
streamId
                    StreamState
_otherwise ->
                        -- The block began on a stream that was open for
                        -- headers or trailers, and the sender has since
                        -- closed it -- a reset crossing the block.  There is
                        -- nothing to deliver, but the block still has to go
                        -- through the decoder, since it may have changed the
                        -- dynamic table.  Handing it to 'stream' as a
                        -- CONTINUATION would get it refused as one that
                        -- cannot come here, closing the connection.
                        ByteString -> Int -> Context -> IO ()
hpackDiscardHeader ByteString
blk Int
streamId Context
ctx
            Maybe Stream
Nothing ->
                ByteString -> Int -> Context -> IO ()
hpackDiscardHeader ByteString
blk Int
streamId Context
ctx

-- | Is this a response that is defined to have no content?
--
-- RFC 9113, section 8.1.1: "A response that is defined to have no content,
-- as described in Section 6.4.1 of [HTTP], can have a non-zero
-- content-length header field, even though no content is included in DATA
-- frames."  Those are the responses to HEAD, 204 and 304, and 2xx to
-- CONNECT; the content-length of one to HEAD, in particular, is that of the
-- content a GET would have had.  Checking it against the content that
-- arrived made every such response to HEAD a stream error.
hasNoContent :: Context -> Stream -> ValueTable -> IO Bool
hasNoContent :: Context -> Stream -> ValueTable -> IO Bool
hasNoContent Context
ctx Stream{IORef (Maybe ByteString)
streamRequestMethod :: IORef (Maybe ByteString)
streamRequestMethod :: Stream -> IORef (Maybe ByteString)
streamRequestMethod} ValueTable
vt
    | Context -> Bool
isServer Context
ctx = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise = do
        Maybe ByteString
mmethod <- IORef (Maybe ByteString) -> IO (Maybe ByteString)
forall a. IORef a -> IO a
readIORef IORef (Maybe ByteString)
streamRequestMethod
        let status :: Maybe ByteString
status = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenStatus ValueTable
vt
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
            Maybe ByteString
mmethod Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"HEAD"
                Bool -> Bool -> Bool
|| Maybe ByteString
status Maybe ByteString -> [Maybe ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"204", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"304"]
                Bool -> Bool -> Bool
|| (Maybe ByteString
mmethod Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"CONNECT" Bool -> Bool -> Bool
&& Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString
"2" ByteString -> ByteString -> Bool
`BS.isPrefixOf`) Maybe ByteString
status)

----------------------------------------------------------------

processState :: StreamState -> Context -> Stream -> StreamId -> IO ()
-- Transition (process1)
processState :: StreamState -> Context -> Stream -> Int -> IO ()
processState (Open Maybe ClosedCode
_ (NoBody tbl :: TokenHeaderTable
tbl@(TokenHeaderList
_, ValueTable
reqvt))) Context
ctx strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput} Int
streamId = do
    -- My SETTINGS_MAX_CONCURRENT_STREAMS
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
isServer Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Int -> IO ()
checkOddConcurrency Context
ctx Int
streamId
    Bool
noContent <- Context -> Stream -> ValueTable -> IO Bool
hasNoContent Context
ctx Stream
strm ValueTable
reqvt
    let mcl :: Maybe Int
mcl = (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenContentLength ValueTable
reqvt Maybe ByteString
-> (ByteString -> Maybe (Int, ByteString))
-> Maybe (Int, ByteString)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Int, ByteString)
C8.readInt)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
noContent Bool -> Bool -> Bool
&& Maybe Int -> (Int -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
0 :: Int))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
                ErrorCode
ProtocolError
                Int
streamId
                ReasonPhrase
"no body but content-length is not zero"
    IORef (Maybe TokenHeaderTable)
tlr <- Maybe TokenHeaderTable -> IO (IORef (Maybe TokenHeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe TokenHeaderTable
forall a. Maybe a
Nothing
    let inpObj :: InpObj
inpObj = TokenHeaderTable
-> Maybe Int -> InpBody -> IORef (Maybe TokenHeaderTable) -> InpObj
InpObj TokenHeaderTable
tbl (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) ((ByteString, Bool) -> InpBody
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
forall a. Monoid a => a
mempty, Bool
True)) IORef (Maybe TokenHeaderTable)
tlr
    if Context -> Bool
isServer Context
ctx
        then do
            Context -> Stream -> InpObj -> IO ()
launchHandler Context
ctx Stream
strm InpObj
inpObj
        else MVar (Either SomeException InpObj)
-> Either SomeException InpObj -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException InpObj)
streamInput (Either SomeException InpObj -> IO ())
-> Either SomeException InpObj -> IO ()
forall a b. (a -> b) -> a -> b
$ InpObj -> Either SomeException InpObj
forall a b. b -> Either a b
Right InpObj
inpObj
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm

-- Transition (process2)
processState (Open Maybe ClosedCode
_ (HasBody tbl :: TokenHeaderTable
tbl@(TokenHeaderList
_, ValueTable
reqvt))) Context
ctx strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput, IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
streamRxQ :: IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
streamRxQ :: Stream
-> IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
streamRxQ} Int
_streamId = do
    -- My SETTINGS_MAX_CONCURRENT_STREAMS
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
isServer Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Int -> IO ()
checkOddConcurrency Context
ctx Int
_streamId
    Bool
noContent <- Context -> Stream -> ValueTable -> IO Bool
hasNoContent Context
ctx Stream
strm ValueTable
reqvt
    let mcl :: Maybe Int
mcl
            -- Its content-length describes content it does not have.
            | Bool
noContent = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
            | Bool
otherwise = (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenContentLength ValueTable
reqvt Maybe ByteString
-> (ByteString -> Maybe (Int, ByteString))
-> Maybe (Int, ByteString)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Int, ByteString)
C8.readInt)
    IORef Int
bodyLength <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
    IORef (Maybe TokenHeaderTable)
tlr <- Maybe TokenHeaderTable -> IO (IORef (Maybe TokenHeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe TokenHeaderTable
forall a. Maybe a
Nothing
    TQueue (Either SomeException (ByteString, Bool))
q <- IO (TQueue (Either SomeException (ByteString, Bool)))
forall a. IO (TQueue a)
newTQueueIO
    IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
-> Maybe (TQueue (Either SomeException (ByteString, Bool)))
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
streamRxQ (Maybe (TQueue (Either SomeException (ByteString, Bool))) -> IO ())
-> Maybe (TQueue (Either SomeException (ByteString, Bool)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException (ByteString, Bool))
-> Maybe (TQueue (Either SomeException (ByteString, Bool)))
forall a. a -> Maybe a
Just TQueue (Either SomeException (ByteString, Bool))
q
    Context -> Stream -> OpenState -> IO ()
setOpenState Context
ctx Stream
strm (OpenState -> IO ()) -> OpenState -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException (ByteString, Bool))
-> Maybe Int
-> IORef Int
-> IORef (Maybe TokenHeaderTable)
-> OpenState
Body TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
tlr
    -- FLOW CONTROL: WINDOW_UPDATE 0: recv: announcing my limit properly
    -- FLOW CONTROL: WINDOW_UPDATE: recv: announcing my limit properly
    Source
bodySource <- TQueue (Either SomeException (ByteString, Bool))
-> (Int -> IO ()) -> IO Source
mkSource TQueue (Either SomeException (ByteString, Bool))
q ((Int -> IO ()) -> IO Source) -> (Int -> IO ()) -> IO Source
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> Int -> IO ()
informWindowUpdate Context
ctx Stream
strm
    let inpObj :: InpObj
inpObj = TokenHeaderTable
-> Maybe Int -> InpBody -> IORef (Maybe TokenHeaderTable) -> InpObj
InpObj TokenHeaderTable
tbl Maybe Int
mcl (Source -> InpBody
readSource Source
bodySource) IORef (Maybe TokenHeaderTable)
tlr
    if Context -> Bool
isServer Context
ctx
        then do
            Context -> Stream -> InpObj -> IO ()
launchHandler Context
ctx Stream
strm InpObj
inpObj
        else MVar (Either SomeException InpObj)
-> Either SomeException InpObj -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException InpObj)
streamInput (Either SomeException InpObj -> IO ())
-> Either SomeException InpObj -> IO ()
forall a b. (a -> b) -> a -> b
$ InpObj -> Either SomeException InpObj
forall a b. b -> Either a b
Right InpObj
inpObj

-- Transition (process4)
processState StreamState
HalfClosedRemote Context
ctx Stream
strm Int
_streamId = do
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm

-- Transition (process5)
processState (Closed ClosedCode
cc) Context
ctx Stream
strm Int
_streamId = do
    Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc

-- Transition (process6)
processState (Open Maybe ClosedCode
_ OpenState
o) Context
ctx Stream
strm Int
_streamId =
    -- Open JustOpened, Open Body.  Not the whole state: see 'setOpenState'.
    Context -> Stream -> OpenState -> IO ()
setOpenState Context
ctx Stream
strm OpenState
o
processState StreamState
s Context
ctx Stream
strm Int
_streamId = do
    -- Idle
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s

-- | Handing a request to the server's handler.
--
-- The stream counts towards the last stream identifier of our GOAWAY from
-- here on: from now its request "might have been processed" (RFC 9113,
-- section 6.8), and a client is free to retry, on another connection, any
-- request on a stream above it.  It used to be counted once the handler
-- had returned, so a GOAWAY sent while handlers were running left their
-- streams out, and a client could send again a request -- a POST, say --
-- that had been acted on.
launchHandler :: Context -> Stream -> InpObj -> IO ()
launchHandler :: Context -> Stream -> InpObj -> IO ()
launchHandler ctx :: Context
ctx@Context{RoleInfo
roleInfo :: Context -> RoleInfo
roleInfo :: RoleInfo
roleInfo} Stream
strm InpObj
inpObj = do
    Context -> Int -> IO ()
modifyPeerLastStreamId Context
ctx (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> Int
streamNumber Stream
strm
    let ServerInfo{Context -> Stream -> InpObj -> IO ()
launch :: Context -> Stream -> InpObj -> IO ()
launch :: ServerInfo -> Context -> Stream -> InpObj -> IO ()
..} = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
    Context -> Stream -> InpObj -> IO ()
launch Context
ctx Stream
strm InpObj
inpObj

----------------------------------------------------------------

{- FOURMOLU_DISABLE -}
getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream)
getStream :: Context -> FrameType -> Int -> IO (Maybe Stream)
getStream ctx :: Context
ctx@Context{TVar Int
TVar (Maybe Int)
TVar (Maybe SomeException)
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe HeaderContinuation)
IORef IntSet
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Output
Manager
ThreadManager
DynamicTable
Settings
ControlQ
RoleInfo
Role
Int -> TokenHeaderTable -> IO ()
receiverDone :: Context -> TVar (Maybe SomeException)
timeoutManager :: Context -> Manager
controlQ :: Context -> ControlQ
resetByMe :: Context -> IORef IntSet
activeRequests :: Context -> TVar Int
peerGoAway :: Context -> TVar (Maybe Int)
informationalCallback :: Context -> Int -> TokenHeaderTable -> IO ()
appDone :: Context -> STM Bool
threadManager :: Context -> ThreadManager
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerLastStreamId :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe HeaderContinuation)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe HeaderContinuation)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: ControlQ
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
timeoutManager :: Manager
receiverDone :: TVar (Maybe SomeException)
appDone :: STM Bool
informationalCallback :: Int -> TokenHeaderTable -> IO ()
peerGoAway :: TVar (Maybe Int)
activeRequests :: TVar Int
resetByMe :: IORef IntSet
..} FrameType
ftyp Int
streamId
  | Bool
isEven    = TVar EvenStreamTable -> Int -> IO (Maybe Stream)
lookupEven TVar EvenStreamTable
evenStreamTable Int
streamId IO (Maybe Stream)
-> (Maybe Stream -> IO (Maybe Stream)) -> IO (Maybe Stream)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)
getEvenStream Context
ctx FrameType
ftyp
  | Bool
otherwise = TVar OddStreamTable -> Int -> IO (Maybe Stream)
lookupOdd TVar OddStreamTable
oddStreamTable  Int
streamId IO (Maybe Stream)
-> (Maybe Stream -> IO (Maybe Stream)) -> IO (Maybe Stream)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> FrameType -> Int -> Maybe Stream -> IO (Maybe Stream)
getOddStream  Context
ctx FrameType
ftyp Int
streamId
  where
    isEven :: Bool
isEven = Int -> Bool
isServerInitiated Int
streamId
{- FOURMOLU_ENABLE -}

getEvenStream :: Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)
getEvenStream :: Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)
getEvenStream Context
ctx FrameType
ftyp js :: Maybe Stream
js@(Just Stream
strm) = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isReserved StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
    Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getEvenStream Context
_ FrameType
_ Maybe Stream
Nothing = Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing

getOddStream
    :: Context -> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getOddStream :: Context -> FrameType -> Int -> Maybe Stream -> IO (Maybe Stream)
getOddStream Context
ctx FrameType
ftyp Int
streamId js :: Maybe Stream
js@(Just Stream
strm0) = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm0
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isHalfClosedRemote StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
StreamClosed
                    Int
streamId
                    ReasonPhrase
"header must not be sent to half or fully closed stream"
        -- Priority made an idle stream
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isIdle StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
strm0
    Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getOddStream Context
ctx FrameType
ftyp Int
streamId Maybe Stream
Nothing
    | Context -> Bool
isServer Context
ctx = do
        Int
csid <- Context -> IO Int
getPeerStreamID Context
ctx
        if Int
streamId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
csid -- consider the stream closed
            then do
                -- RFC 9113 section 5.1: "An endpoint MUST ignore frames that
                -- it receives on closed streams after it has sent a
                -- RST_STREAM frame."  DATA is in that list because resetting a
                -- stream mid-body leaves whatever the peer already put on the
                -- wire still to arrive.  HEADERS is, for a stream we reset:
                -- trailers the peer sent before our reset reached it.  They
                -- used to close the connection, every other stream on it with
                -- it.  Their field block is still decoded, for the dynamic
                -- table ('hpackDiscardHeader'), CONTINUATION and all.
                -- HEADERS on any other closed
                -- stream is the reuse of a stream identifier, which section
                -- 5.1.1 makes a connection error.
                Bool
resetByUs <- Context -> Int -> IO Bool
wasResetByMe Context
ctx Int
streamId
                if FrameType
ftyp FrameType -> [FrameType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameType
FrameData, FrameType
FrameWindowUpdate, FrameType
FrameRSTStream, FrameType
FramePriority]
                    Bool -> Bool -> Bool
|| (FrameType
ftyp FrameType -> [FrameType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameType
FrameHeaders, FrameType
FrameContinuation] Bool -> Bool -> Bool
&& Bool
resetByUs)
                    then Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing -- will be ignored
                    else
                        HTTP2Error -> IO (Maybe Stream)
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO (Maybe Stream))
-> HTTP2Error -> IO (Maybe Stream)
forall a b. (a -> b) -> a -> b
$
                            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                                ErrorCode
ProtocolError
                                Int
streamId
                                ReasonPhrase
"stream identifier must not decrease"
            else do
                -- consider the stream idle
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> [FrameType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameType
FrameHeaders, FrameType
FramePriority]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    let errmsg :: ReasonPhrase
errmsg =
                            ByteString -> ReasonPhrase
Short.toShort
                                ( ByteString
"this frame is not allowed in an idle stream: "
                                    ByteString -> ByteString -> ByteString
`BS.append` [Char] -> ByteString
C8.pack (FrameType -> [Char]
forall a. Show a => a -> [Char]
show FrameType
ftyp)
                                )
                    HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
errmsg
                if FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePriority
                    then
                        -- PRIORITY does not open a stream (RFC 9113, section
                        -- 5.1): it is checked and dropped like one for a
                        -- stream we do not have.  It used to create the
                        -- stream, taking a concurrency slot that nothing ever
                        -- gave back, since no HEADERS need follow: a peer
                        -- could fill SETTINGS_MAX_CONCURRENT_STREAMS with
                        -- PRIORITY frames alone and have every request after
                        -- them refused.
                        Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing
                    else do
                        Context -> Int -> IO ()
setPeerStreamID Context
ctx Int
streamId
                        -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit
                        Stream -> Maybe Stream
forall a. a -> Maybe a
Just (Stream -> Maybe Stream) -> IO Stream -> IO (Maybe Stream)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> FrameType -> IO Stream
openOddStreamCheck Context
ctx Int
streamId FrameType
ftyp
    | Bool
otherwise =
        -- We received a frame from the server on an unknown stream
        -- (likely a previously created and then subsequently reset stream).
        -- We just drop it.
        Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing

----------------------------------------------------------------

type Payload = ByteString

control :: FrameType -> FrameHeader -> Payload -> Context -> IO ()
control :: FrameType -> FrameHeader -> ByteString -> Context -> IO ()
control FrameType
FrameSettings header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
bs Context{IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings :: IORef Bool
myFirstSettings, ControlQ
controlQ :: Context -> ControlQ
controlQ :: ControlQ
controlQ, Rate
settingsRate :: Context -> Rate
settingsRate :: Rate
settingsRate, Settings
mySettings :: Context -> Settings
mySettings :: Settings
mySettings, IORef RxFlow
rxFlow :: Context -> IORef RxFlow
rxFlow :: IORef RxFlow
rxFlow} = do
    SettingsFrame SettingsList
peerAlist <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeSettingsFrame FrameHeader
header ByteString
bs
    (HTTP2Error -> IO Any) -> Maybe HTTP2Error -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ HTTP2Error -> IO Any
forall e a. Exception e => e -> IO a
E.throwIO (Maybe HTTP2Error -> IO ()) -> Maybe HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
peerAlist
    if FrameFlags -> Bool
testAck FrameFlags
flags
        then do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SettingsList
peerAlist SettingsList -> SettingsList -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError Int
streamId ReasonPhrase
"ack settings has a body"
        else do
            -- Settings Flood - CVE-2019-9515
            Int
rate <- Rate -> IO Int
getRate Rate
settingsRate
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
settingsRateLimit Settings
mySettings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many settings"
            let ack :: ByteString
ack = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
setAck []
            Bool
sent <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
myFirstSettings
            if Bool
sent
                then do
                    let setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (SettingsList -> Maybe SettingsList
forall a. a -> Maybe a
Just SettingsList
peerAlist) [ByteString
ack]
                    ControlQ -> Control -> IO ()
enqueueControl ControlQ
controlQ Control
setframe
                else do
                    -- Server side only
                    Int
connRxWS <- RxFlow -> Int
rxfBufSize (RxFlow -> Int) -> IO RxFlow -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef RxFlow -> IO RxFlow
forall a. IORef a -> IO a
readIORef IORef RxFlow
rxFlow
                    let frames :: [ByteString]
frames = Settings -> Int -> [ByteString]
makeNegotiationFrames Settings
mySettings Int
connRxWS
                        setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (SettingsList -> Maybe SettingsList
forall a. a -> Maybe a
Just SettingsList
peerAlist) ([ByteString]
frames [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
ack])
                    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
myFirstSettings Bool
True
                    ControlQ -> Control -> IO ()
enqueueControl ControlQ
controlQ Control
setframe
control FrameType
FramePing FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
bs ctx :: Context
ctx@Context{Settings
mySettings :: Context -> Settings
mySettings :: Settings
mySettings, Rate
pingRate :: Context -> Rate
pingRate :: Rate
pingRate} =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FrameFlags -> Bool
testAck FrameFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int
rate <- Rate -> IO Int
getRate Rate
pingRate
        if Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
pingRateLimit Settings
mySettings
            then HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many ping"
            else Context -> Bool -> ByteString -> IO ()
sendPing Context
ctx Bool
True ByteString
bs
control FrameType
FrameGoAway FrameHeader
header ByteString
bs Context
ctx = do
    GoAwayFrame Int
sid ErrorCode
err ByteString
msg <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeGoAwayFrame FrameHeader
header ByteString
bs
    if ErrorCode
err ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorCode
NoError
        then do
            Bool
first <- Context -> Int -> IO Bool
goingAway Context
ctx Int
sid
            -- The receiver goes on reading for the streams left, and stops
            -- the way it does when the peer closes the connection, once
            -- they are done.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
first (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ThreadId
receiver <- IO ThreadId
myThreadId
                ThreadManager -> [Char] -> IO () -> IO ()
T.forkManaged (Context -> ThreadManager
threadManager Context
ctx) [Char]
"H2 draining after GOAWAY" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> STM ()
drained Context
ctx
                    ThreadId -> HTTP2Error -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
E.throwTo ThreadId
receiver HTTP2Error
ConnectionIsClosed
        else HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsReceived ErrorCode
err Int
sid (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$ ByteString -> ReasonPhrase
Short.toShort ByteString
msg
control FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
ctx = do
    WindowUpdateFrame Int
n <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Context -> Int -> IO ()
increaseConnectionWindowSize Context
ctx Int
n
control FrameType
_ FrameHeader
_ ByteString
_ Context
_ =
    -- must not reach here
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------

-- Called in client only
push :: FrameHeader -> ByteString -> Context -> IO ()
push :: FrameHeader -> ByteString -> Context -> IO ()
push header :: FrameHeader
header@FrameHeader{Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
bs Context
ctx = do
    PushPromiseFrame Int
sid ByteString
frag <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePushPromiseFrame FrameHeader
header ByteString
bs
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
isServerInitiated Int
sid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                ErrorCode
ProtocolError
                Int
streamId
                ReasonPhrase
"push promise must specify an even stream identifier"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
frag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                ErrorCode
ProtocolError
                Int
streamId
                ReasonPhrase
"wrong header fragment for push promise"
    -- A malformed promised request is an error on the promised stream,
    -- which 'resetPromised' resets.
    (TokenHeaderList
_, ValueTable
vt) <- ByteString -> Int -> Context -> IO TokenHeaderTable
hpackDecodeHeader ByteString
frag Int
streamId Context
ctx IO TokenHeaderTable
-> (HTTP2Error -> IO TokenHeaderTable) -> IO TokenHeaderTable
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` Int -> HTTP2Error -> IO TokenHeaderTable
forall a. Int -> HTTP2Error -> IO a
onPromised Int
sid
    let ClientInfo{[Char]
ByteString
scheme :: ByteString
authority :: [Char]
authority :: ClientInfo -> [Char]
scheme :: ClientInfo -> ByteString
..} = RoleInfo -> ClientInfo
toClientInfo (RoleInfo -> ClientInfo) -> RoleInfo -> ClientInfo
forall a b. (a -> b) -> a -> b
$ Context -> RoleInfo
roleInfo Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
        ( Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenAuthority ValueTable
vt Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ([Char] -> ByteString
UTF8.fromString [Char]
authority)
            Bool -> Bool -> Bool
&& Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenScheme ValueTable
vt Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
scheme
        )
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let mmethod :: Maybe ByteString
mmethod = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenMethod ValueTable
vt
                mpath :: Maybe ByteString
mpath = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenPath ValueTable
vt
            case (Maybe ByteString
mmethod, Maybe ByteString
mpath) of
                (Just ByteString
method, Just ByteString
path) ->
                    -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit
                    Context -> Int -> ByteString -> ByteString -> IO ()
openEvenStreamCacheCheck Context
ctx Int
sid ByteString
method ByteString
path
                (Maybe ByteString, Maybe ByteString)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------

onPromised :: StreamId -> HTTP2Error -> IO a
onPromised :: forall a. Int -> HTTP2Error -> IO a
onPromised Int
sid (StreamErrorIsSent ErrorCode
err Int
_ ReasonPhrase
msg) = HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
err Int
sid ReasonPhrase
msg
onPromised Int
_ HTTP2Error
e = HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e

{-# INLINE guardIt #-}
guardIt :: Either FrameDecodeError a -> IO a
guardIt :: forall a. Either FrameDecodeError a -> IO a
guardIt Either FrameDecodeError a
x = case Either FrameDecodeError a
x of
    Left (FrameDecodeError ErrorCode
ec Int
sid ReasonPhrase
msg) -> HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec Int
sid ReasonPhrase
msg
    Right a
frame -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
frame

{-# INLINE checkPriority #-}
checkPriority :: Priority -> StreamId -> IO ()
checkPriority :: Priority -> Int -> IO ()
checkPriority Priority
p Int
me
    | Int
dep Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
me =
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
me ReasonPhrase
"priority depends on itself"
    | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    dep :: Int
dep = Priority -> Int
streamDependency Priority
p

-- | Handle a decoded response HEADERS section. On the client, a 1xx
--   informational response (e.g. 103 Early Hints) is delivered to the
--   informational callback and the stream keeps waiting for the final response;
--   otherwise the headers become the (final) response.
onResponseHeaders
    :: Context
    -> StreamId
    -> Maybe ClosedCode
    -> Bool
    -> TokenHeaderTable
    -> IO StreamState
onResponseHeaders :: Context
-> Int
-> Maybe ClosedCode
-> Bool
-> TokenHeaderTable
-> IO StreamState
onResponseHeaders Context
ctx Int
streamId Maybe ClosedCode
hcl Bool
endOfStream TokenHeaderTable
tbl
    | Bool
endOfStream = StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (TokenHeaderTable -> OpenState
NoBody TokenHeaderTable
tbl)
    | Context -> Role
role Context
ctx Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Client Bool -> Bool -> Bool
&& Bool
isInformational = do
        Context -> Int -> TokenHeaderTable -> IO ()
informationalCallback Context
ctx Int
streamId TokenHeaderTable
tbl
        StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl OpenState
JustOpened
    | Bool
otherwise = StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (TokenHeaderTable -> OpenState
HasBody TokenHeaderTable
tbl)
  where
    isInformational :: Bool
isInformational =
        Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString
"1" ByteString -> ByteString -> Bool
`BS.isPrefixOf`) (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenStatus (TokenHeaderTable -> ValueTable
forall a b. (a, b) -> b
snd TokenHeaderTable
tbl)

stream
    :: FrameType
    -> FrameHeader
    -> ByteString
    -> Context
    -> StreamState
    -> Stream
    -> IO StreamState
-- Transition (stream1)
stream :: FrameType
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
bs Context
ctx s :: StreamState
s@(Open Maybe ClosedCode
hcl OpenState
JustOpened) Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber} = do
    HeadersFrame Maybe Priority
mp ByteString
frag <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
        endOfHeader :: Bool
endOfHeader = FrameFlags -> Bool
testEndHeader FrameFlags
flags
    if ByteString
frag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfStream Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfHeader
        then do
            -- Empty Frame Flooding - CVE-2019-9518
            Int
rate <- Rate -> IO Int
getRate (Rate -> IO Int) -> Rate -> IO Int
forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
            if Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
emptyFrameRateLimit (Context -> Settings
mySettings Context
ctx)
                then
                    HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many empty headers"
                else StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
        else do
            case Maybe Priority
mp of
                Maybe Priority
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just Priority
p -> Priority -> Int -> IO ()
checkPriority Priority
p Int
streamNumber
            if Bool
endOfHeader
                then do
                    TokenHeaderTable
tbl <- ByteString -> Int -> Context -> IO TokenHeaderTable
hpackDecodeHeader ByteString
frag Int
streamId Context
ctx
                    Context
-> Int
-> Maybe ClosedCode
-> Bool
-> TokenHeaderTable
-> IO StreamState
onResponseHeaders Context
ctx Int
streamId Maybe ClosedCode
hcl Bool
endOfStream TokenHeaderTable
tbl
                else do
                    Context -> Int -> Bool -> ByteString -> IO ()
startHeaderBlock Context
ctx Int
streamId Bool
endOfStream ByteString
frag
                    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- Transition (stream2)
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
bs Context
ctx s :: StreamState
s@(Open Maybe ClosedCode
_ (Body TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
tlr)) Stream
_ = do
    HeadersFrame Maybe Priority
_ ByteString
frag <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
    -- checking frag == "" is not necessary
    if Bool
endOfStream
        then do
            if FrameFlags -> Bool
testEndHeader FrameFlags
flags
                then Context
-> Int
-> ByteString
-> TQueue (Either SomeException (ByteString, Bool))
-> Maybe Int
-> IORef Int
-> IORef (Maybe TokenHeaderTable)
-> IO StreamState
onTrailers Context
ctx Int
streamId ByteString
frag TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
tlr
                else do
                    Context -> Int -> Bool -> ByteString -> IO ()
startHeaderBlock Context
ctx Int
streamId Bool
endOfStream ByteString
frag
                    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
        else
            HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
                ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
ProtocolError
                    Int
streamId
                    ReasonPhrase
"trailers without END_STREAM"

-- Transition (stream4)
stream
    FrameType
FrameData
    header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId}
    ByteString
bs
    ctx :: Context
ctx@Context{Rate
emptyFrameRate :: Context -> Rate
emptyFrameRate :: Rate
emptyFrameRate, IORef RxFlow
rxFlow :: Context -> IORef RxFlow
rxFlow :: IORef RxFlow
rxFlow, Settings
mySettings :: Context -> Settings
mySettings :: Settings
mySettings}
    s :: StreamState
s@(Open Maybe ClosedCode
_ (Body TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
_))
    strm :: Stream
strm@Stream{Int
MVar (Either SomeException InpObj)
TVar Bool
TVar TxFlow
TVar StreamState
IORef (Maybe ByteString)
IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
IORef RxFlow
streamRequestMethod :: Stream -> IORef (Maybe ByteString)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamRxQ :: Stream
-> IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
streamNumber :: Stream -> Int
streamNumber :: Int
streamState :: TVar StreamState
streamInput :: MVar (Either SomeException InpObj)
streamTxFlow :: TVar TxFlow
streamRxFlow :: IORef RxFlow
streamRxQ :: IORef (Maybe (TQueue (Either SomeException (ByteString, Bool))))
streamRequestMethod :: IORef (Maybe ByteString)
streamDiscardBody :: TVar Bool
streamDiscardBody :: Stream -> TVar Bool
streamRxFlow :: Stream -> IORef RxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamState :: Stream -> TVar StreamState
..} = do
        DataFrame ByteString
body <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeDataFrame FrameHeader
header ByteString
bs
        -- FLOW CONTROL: WINDOW_UPDATE 0: recv: rejecting if over my limit
        Bool
okc <- IORef RxFlow -> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef RxFlow
rxFlow ((RxFlow -> (RxFlow, Bool)) -> IO Bool)
-> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> RxFlow -> (RxFlow, Bool)
checkRxLimit Int
payloadLength
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
okc (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
EnhanceYourCalm
                    Int
streamId
                    ReasonPhrase
"exceeds connection flow-control limit"
        -- FLOW CONTROL: WINDOW_UPDATE: recv: rejecting if over my limit
        Bool
oks <- IORef RxFlow -> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef RxFlow
streamRxFlow ((RxFlow -> (RxFlow, Bool)) -> IO Bool)
-> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> RxFlow -> (RxFlow, Bool)
checkRxLimit Int
payloadLength
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
oks (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
EnhanceYourCalm
                    Int
streamId
                    ReasonPhrase
"exceeds stream flow-control limit"
        -- A push gives the connection window everything back now, padding
        -- and all ('connectionCreditedOnArrival'); its stream window, and
        -- any other stream's windows, as below.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
connectionCreditedOnArrival Int
streamId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Context -> Int -> IO ()
giveBackConnectionWindow Context
ctx Int
payloadLength
        -- The padding is charged to both windows, as it must be, but it
        -- never reaches the reader, whose reading is what gives octets
        -- back ('readSource').  Left there, each padded frame shrank the
        -- peer's windows for good, until the connection stalled.  It is
        -- done with as soon as it arrives, so it goes straight back.
        Context -> Stream -> Int -> IO ()
informWindowUpdate Context
ctx Stream
strm (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
payloadLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
body
        Int
len0 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
bodyLength
        -- The content itself: 'payloadLength', which flow control goes by,
        -- also counts the padding, and so made a padded body look longer
        -- than its content-length.
        let len :: Int
len = Int
len0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
body
            endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
        -- RFC 9113, section 8.1.1: a body that does not add up to its
        -- content-length makes the message malformed.  Checked before any
        -- of this frame is delivered: it used to be checked once the last
        -- of the body had been queued with END_STREAM, and the reader took
        -- the body for complete before the reset reached it -- a server
        -- handler, say, or a proxy that went by the content-length.  Now
        -- the reader gets the reset ('closed', by 'resettable') in place of
        -- the end, and a body longer than its content-length is cut off as
        -- soon as it is.  What is not queued goes back to the connection
        -- window.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> (Int -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>) Bool -> Bool -> Bool
|| (Bool
endOfStream Bool -> Bool -> Bool
&& Maybe Int -> (Int -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
connectionCreditedOnArrival Int
streamId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Context -> Int -> IO ()
giveBackConnectionWindow Context
ctx (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ByteString -> Int
BS.length ByteString
body
            HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
                    ErrorCode
ProtocolError
                    Int
streamId
                    ReasonPhrase
"actual body length is not the same as content-length"
        -- Empty Frame Flooding - CVE-2019-9518
        if ByteString
body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
""
            then Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
endOfStream (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Int
rate <- Rate -> IO Int
getRate Rate
emptyFrameRate
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
emptyFrameRateLimit Settings
mySettings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many empty data"
            else do
                IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
bodyLength Int
len
                -- Not for a stream closed since its state was read, by
                -- a reader that has done with it ('giveBackUnread') or a
                -- reset of ours: nothing would ever read it, or give it
                -- back to the connection window.  Nor for one whose
                -- handler has returned ('streamDiscardBody'): nobody
                -- will read it either, and it is given back to both
                -- windows, so that the peer can send the rest and end
                -- the stream.  Checked in the same transaction, so that
                -- a closer that has emptied the queue finds nothing put
                -- in after it.
                DataOutcome
outcome <- STM DataOutcome -> IO DataOutcome
forall a. STM a -> IO a
atomically (STM DataOutcome -> IO DataOutcome)
-> STM DataOutcome -> IO DataOutcome
forall a b. (a -> b) -> a -> b
$ do
                    StreamState
st <- TVar StreamState -> STM StreamState
forall a. TVar a -> STM a
readTVar TVar StreamState
streamState
                    Bool
discard <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
streamDiscardBody
                    if
                        | StreamState -> Bool
isClosed StreamState
st -> DataOutcome -> STM DataOutcome
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return DataOutcome
Dropped
                        | Bool
discard -> DataOutcome -> STM DataOutcome
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return DataOutcome
Discarded
                        | Bool
otherwise -> do
                            TQueue (Either SomeException (ByteString, Bool))
-> Either SomeException (ByteString, Bool) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException (ByteString, Bool))
q (Either SomeException (ByteString, Bool) -> STM ())
-> Either SomeException (ByteString, Bool) -> STM ()
forall a b. (a -> b) -> a -> b
$ (ByteString, Bool) -> Either SomeException (ByteString, Bool)
forall a b. b -> Either a b
Right (ByteString
body, Bool
endOfStream)
                            DataOutcome -> STM DataOutcome
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return DataOutcome
Queued
                case DataOutcome
outcome of
                    DataOutcome
Queued -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    DataOutcome
Discarded -> Context -> Stream -> Int -> IO ()
informWindowUpdate Context
ctx Stream
strm (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
body
                    DataOutcome
Dropped ->
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
connectionCreditedOnArrival Int
streamId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            Context -> Int -> IO ()
giveBackConnectionWindow Context
ctx (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$
                                ByteString -> Int
BS.length ByteString
body
        if Bool
endOfStream
            then do
                -- no trailers
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException (ByteString, Bool))
-> Either SomeException (ByteString, Bool) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException (ByteString, Bool))
q (Either SomeException (ByteString, Bool) -> STM ())
-> Either SomeException (ByteString, Bool) -> STM ()
forall a b. (a -> b) -> a -> b
$ (ByteString, Bool) -> Either SomeException (ByteString, Bool)
forall a b. b -> Either a b
Right (ByteString
forall a. Monoid a => a
mempty, Bool
True)
                StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
            else StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- (No state transition)
stream FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
_ StreamState
s Stream
strm = do
    WindowUpdateFrame Int
n <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Stream -> Int -> IO ()
increaseStreamWindowSize Stream
strm Int
n
    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- Transition (stream6)
stream FrameType
FrameRSTStream header :: FrameHeader
header@FrameHeader{Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
bs Context
ctx StreamState
s Stream
strm = do
    -- Rapid Rest: CVE-2023-44487
    Int
rate <- Rate -> IO Int
getRate (Rate -> IO Int) -> Rate -> IO Int
forall a b. (a -> b) -> a -> b
$ Context -> Rate
rstRate Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Settings -> Int
rstRateLimit (Context -> Settings
mySettings Context
ctx)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many rst_stream"
    RSTStreamFrame ErrorCode
err <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeRSTStreamFrame FrameHeader
header ByteString
bs
    let cc :: ClosedCode
cc = ErrorCode -> ClosedCode
Reset ErrorCode
err
    Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc

    -- HTTP2 spec, section 5.1, "Stream States":
    --
    -- > A stream in the "open" state may be used by both peers to send frames
    -- > of any type. (..) From this state, either endpoint can send a frame
    -- > with an END_STREAM flag set, which causes the stream to transition into
    -- > one of the "half-closed" states.  An endpoint sending an END_STREAM
    -- > flag causes the stream state to become "half-closed (local)"; an
    -- > endpoint receiving an END_STREAM flag causes the stream state to become
    -- > "half-closed (remote)".
    --
    -- Crucially (for the specific case we're dealing with here), it continues:
    --
    -- > /Either endpoint/ can send a RST_STREAM frame from this state, causing
    -- > it to transition immediately to "closed".
    --
    -- (emphasis not in original).
    --
    -- In addition, the spec states (about the open state):
    --
    -- > Either endpoint can send a RST_STREAM frame from this state, causing it
    -- > to transition immediately to "closed".
    --
    -- This justifies the non-error cases, below. (Section 8.1 of the spec
    -- is also relevant, but it is less explicit about the /either endpoint/
    -- part.)
    --
    -- The error code the peer sent does not enter into it.  Receiving a
    -- RST_STREAM closes that stream and nothing else, whatever the reason
    -- given; the code is for whoever is reading the stream, and reaches them
    -- as 'StreamResetIsReceived' by way of 'closed' above.  Ending the whole
    -- connection over it would punish every other stream on the connection
    -- for a peer's complaint about one.
    case StreamState
s of
        -- Open /or/ half-closed (local)
        Open Maybe ClosedCode
_ OpenState
_ -> StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        StreamState
HalfClosedRemote -> StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        StreamState
Reserved -> StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        Closed ClosedCode
_ -> StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        -- Only an idle stream is left, which a PRIORITY frame can have
        -- created. Section 5.1 again, on "idle": "Receiving any frame other
        -- than HEADERS or PRIORITY on a stream in this state MUST be treated
        -- as a connection error (Section 5.4.1) of type PROTOCOL_ERROR."
        StreamState
Idle ->
            HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
                ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
ProtocolError
                    Int
streamId
                    ReasonPhrase
"rst_stream on an idle stream"
-- (No state transition)
stream FrameType
FramePriority FrameHeader
header ByteString
bs Context
_ StreamState
s Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber} = do
    -- ignore
    -- Resource Loop - CVE-2019-9513
    PriorityFrame Priority
newpri <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
    Priority -> Int -> IO ()
checkPriority Priority
newpri Int
streamNumber
    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- this ordering is important
stream FrameType
FrameContinuation FrameHeader{Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"continue frame cannot come here"
-- DATA that is not taken in, below, is still paid for.  RFC 9113 section
-- 6.9: "A receiver that receives a flow-controlled frame MUST always account
-- for its contribution against the connection flow-control window, unless
-- the receiver treats this as a connection error."  The peer charged it to
-- the connection window before sending it, and unless it is charged and
-- given back here as well, the peer's view of that window shrinks for good.
--
-- Ignore frames to streams we have just reset, per section 5.1.
stream FrameType
FrameData FrameHeader{Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
_ Context
ctx st :: StreamState
st@(Closed (ResetByMe SomeException
_)) Stream
_ = do
    Context -> Int -> Int -> IO ()
informIgnoredData Context
ctx Int
streamId Int
payloadLength
    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
st
stream FrameType
_ FrameHeader
_ ByteString
_ Context
_ st :: StreamState
st@(Closed (ResetByMe SomeException
_)) Stream
_ = StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
st
stream FrameType
FrameData FrameHeader{Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength, Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
_ Context
ctx StreamState
_ Stream
_ = do
    Context -> Int -> Int -> IO ()
informIgnoredData Context
ctx Int
streamId Int
payloadLength
    HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
StreamClosed Int
streamId (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$
            [Char] -> ReasonPhrase
forall a. IsString a => [Char] -> a
fromString ([Char]
"illegal data frame for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
streamId)
stream FrameType
x FrameHeader{Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
streamId (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$
            [Char] -> ReasonPhrase
forall a. IsString a => [Char] -> a
fromString ([Char]
"illegal frame " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FrameType -> [Char]
forall a. Show a => a -> [Char]
show FrameType
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
streamId)

----------------------------------------------------------------

-- | What became of the content of a DATA frame.
data DataOutcome
    = -- | Put in the stream's queue for the reader
      Queued
    | -- | Thrown away, the reader gone ('streamDiscardBody')
      Discarded
    | -- | Thrown away, the stream closed
      Dropped

----------------------------------------------------------------

-- | Type for input streaming.
data Source = Source RxQ (Int -> IO ()) (IORef Bool)

mkSource :: RxQ -> (Int -> IO ()) -> IO Source
mkSource :: TQueue (Either SomeException (ByteString, Bool))
-> (Int -> IO ()) -> IO Source
mkSource TQueue (Either SomeException (ByteString, Bool))
q Int -> IO ()
inform = TQueue (Either SomeException (ByteString, Bool))
-> (Int -> IO ()) -> IORef Bool -> Source
Source TQueue (Either SomeException (ByteString, Bool))
q Int -> IO ()
inform (IORef Bool -> Source) -> IO (IORef Bool) -> IO Source
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

readSource :: Source -> IO (ByteString, Bool)
readSource :: Source -> InpBody
readSource (Source TQueue (Either SomeException (ByteString, Bool))
q Int -> IO ()
inform IORef Bool
refEOF) = do
    Bool
eof <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
refEOF
    if Bool
eof
        then (ByteString, Bool) -> InpBody
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
forall a. Monoid a => a
mempty, Bool
True)
        else do
            Either SomeException (ByteString, Bool)
mBS <- STM (Either SomeException (ByteString, Bool))
-> IO (Either SomeException (ByteString, Bool))
forall a. STM a -> IO a
atomically (STM (Either SomeException (ByteString, Bool))
 -> IO (Either SomeException (ByteString, Bool)))
-> STM (Either SomeException (ByteString, Bool))
-> IO (Either SomeException (ByteString, Bool))
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException (ByteString, Bool))
-> STM (Either SomeException (ByteString, Bool))
forall a. TQueue a -> STM a
readTQueue TQueue (Either SomeException (ByteString, Bool))
q
            case Either SomeException (ByteString, Bool)
mBS of
                Left SomeException
err -> do
                    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
True
                    SomeException -> InpBody
forall e a. Exception e => e -> IO a
E.throwIO SomeException
err
                Right (ByteString
bs, Bool
isEOF) -> do
                    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
isEOF
                    let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
                    Int -> IO ()
inform Int
len
                    (ByteString, Bool) -> InpBody
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, Bool
isEOF)

----------------------------------------------------------------

closureClient :: Config -> Context -> Either E.SomeException a -> IO a
closureClient :: forall a. Config -> Context -> Either SomeException a -> IO a
closureClient Config
conf Context
ctx (Right a
x) = do
    ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
NoError ByteString
"no error"
    Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
closureClient Config
conf Context
ctx (Left SomeException
se) = Config -> Context -> SomeException -> IO a
forall a. Config -> Context -> SomeException -> IO a
closureServer Config
conf Context
ctx SomeException
se

closureServer :: Config -> Context -> E.SomeException -> IO a
closureServer :: forall a. Config -> Context -> SomeException -> IO a
closureServer Config
conf Context
ctx SomeException
se
    | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
se = do
        ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
NoError ByteString
"maybe timeout by manager"
        Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
        SomeException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO SomeException
se
    | Just HTTP2Error
ConnectionIsClosed <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
NoError ByteString
"no error"
        Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
ConnectionIsClosed
    | Just HTTP2Error
ConnectionIsTimeout <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
NoError ByteString
"timeout"
        Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
ConnectionIsTimeout
    | Just e :: HTTP2Error
e@(ConnectionErrorIsReceived ErrorCode
_err Int
_sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
NoError (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
        Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
    | Just e :: HTTP2Error
e@(ConnectionErrorIsSent ErrorCode
err Int
_sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
err (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
        Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
    | Just e :: HTTP2Error
e@(StreamErrorIsSent ErrorCode
err Int
_sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        let frame :: ByteString
frame = ErrorCode -> Int -> ByteString
resetFrame ErrorCode
err Int
_sid
        ByteString
frame' <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
err (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
        Config -> ByteString -> IO ()
sendGoaway Config
conf (ByteString
frame ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
frame')
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
    | Just e :: HTTP2Error
e@(StreamErrorIsReceived ErrorCode
err Int
_sid) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        ByteString
frame <- Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
err ByteString
"treat a stream error as a connection error"
        Config -> ByteString -> IO ()
sendGoaway Config
conf ByteString
frame
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
    | Just (HTTP2Error
_ :: HTTP2Error) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = SomeException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO SomeException
se
    | Bool
otherwise = HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> HTTP2Error
BadThingHappen SomeException
se

goaway :: Context -> ErrorCode -> ByteString -> IO ByteString
goaway :: Context -> ErrorCode -> ByteString -> IO ByteString
goaway Context
ctx ErrorCode
err ByteString
msg = do
    Int
sid <- Context -> IO Int
getPeerLastStreamId Context
ctx
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
sid ErrorCode
err ByteString
msg

sendGoaway :: Config -> ByteString -> IO ()
sendGoaway :: Config -> ByteString -> IO ()
sendGoaway Config{Bool
Int
Buffer
SockAddr
Manager
Int -> IO ByteString
Int -> TokenHeaderTable -> IO ()
PositionReadMaker
ByteString -> IO ()
confOnInformational :: Config -> Int -> TokenHeaderTable -> IO ()
confReadNTimeout :: Config -> Bool
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confReadNTimeout :: Bool
confOnInformational :: Int -> TokenHeaderTable -> IO ()
..} ByteString
frame = ByteString -> IO ()
confSendAll ByteString
frame IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`E.catchIOError` \IOError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------

sendPing :: Context -> Bool -> ByteString -> IO ()
sendPing :: Context -> Bool -> ByteString -> IO ()
sendPing Context{TVar Int
TVar (Maybe Int)
TVar (Maybe SomeException)
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe HeaderContinuation)
IORef IntSet
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Output
Manager
ThreadManager
DynamicTable
Settings
ControlQ
RoleInfo
Role
Int -> TokenHeaderTable -> IO ()
receiverDone :: Context -> TVar (Maybe SomeException)
timeoutManager :: Context -> Manager
controlQ :: Context -> ControlQ
resetByMe :: Context -> IORef IntSet
activeRequests :: Context -> TVar Int
peerGoAway :: Context -> TVar (Maybe Int)
informationalCallback :: Context -> Int -> TokenHeaderTable -> IO ()
appDone :: Context -> STM Bool
threadManager :: Context -> ThreadManager
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerLastStreamId :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe HeaderContinuation)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe HeaderContinuation)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: ControlQ
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
timeoutManager :: Manager
receiverDone :: TVar (Maybe SomeException)
appDone :: STM Bool
informationalCallback :: Int -> TokenHeaderTable -> IO ()
peerGoAway :: TVar (Maybe Int)
activeRequests :: TVar Int
resetByMe :: IORef IntSet
..} Bool
ack ByteString
bs = ControlQ -> Control -> IO ()
enqueueControl ControlQ
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ByteString
frame]
  where
    frame :: ByteString
frame = Bool -> ByteString -> ByteString
pingFrame Bool
ack ByteString
bs

----------------------------------------------------------------

-- | Deliver a complete trailer block: the body ends with it.
--
-- So it has to add up to its content-length, as it does when it ends with
-- END_STREAM on DATA ('stream').  It was not checked here at all: a body
-- of any length went through as long as trailers ended it.  Checked once
-- the block is decoded, for the dynamic table.
onTrailers
    :: Context
    -> StreamId
    -> HeaderBlockFragment
    -> TQueue (Either E.SomeException (ByteString, Bool))
    -> Maybe Int
    -- ^ content-length
    -> IORef Int
    -- ^ The length of the body received
    -> IORef (Maybe TokenHeaderTable)
    -> IO StreamState
onTrailers :: Context
-> Int
-> ByteString
-> TQueue (Either SomeException (ByteString, Bool))
-> Maybe Int
-> IORef Int
-> IORef (Maybe TokenHeaderTable)
-> IO StreamState
onTrailers Context
ctx Int
streamId ByteString
blk TQueue (Either SomeException (ByteString, Bool))
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe TokenHeaderTable)
tlr = do
    TokenHeaderTable
tbl <- ByteString -> Int -> Context -> IO TokenHeaderTable
hpackDecodeTrailer ByteString
blk Int
streamId Context
ctx
    Int
len <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
bodyLength
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> (Int -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
len)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
                ErrorCode
ProtocolError
                Int
streamId
                ReasonPhrase
"actual body length is not the same as content-length"
    IORef (Maybe TokenHeaderTable) -> Maybe TokenHeaderTable -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe TokenHeaderTable)
tlr (TokenHeaderTable -> Maybe TokenHeaderTable
forall a. a -> Maybe a
Just TokenHeaderTable
tbl)
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException (ByteString, Bool))
-> Either SomeException (ByteString, Bool) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException (ByteString, Bool))
q (Either SomeException (ByteString, Bool) -> STM ())
-> Either SomeException (ByteString, Bool) -> STM ()
forall a b. (a -> b) -> a -> b
$ (ByteString, Bool) -> Either SomeException (ByteString, Bool)
forall a b. b -> Either a b
Right (ByteString
forall a. Monoid a => a
mempty, Bool
True)
    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote

-- | Start accumulating a header block that does not fit in a single frame
startHeaderBlock
    :: Context
    -> StreamId
    -> Bool
    -- ^ END_STREAM, from the HEADERS frame
    -> HeaderBlockFragment
    -- ^ The fragment in the HEADERS frame
    -> IO ()
startHeaderBlock :: Context -> Int -> Bool -> ByteString -> IO ()
startHeaderBlock Context{IORef (Maybe HeaderContinuation)
continued :: Context -> IORef (Maybe HeaderContinuation)
continued :: IORef (Maybe HeaderContinuation)
continued} Int
streamId Bool
endOfStream ByteString
frag =
    IORef (Maybe HeaderContinuation)
-> Maybe HeaderContinuation -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe HeaderContinuation)
continued (Maybe HeaderContinuation -> IO ())
-> (HeaderContinuation -> Maybe HeaderContinuation)
-> HeaderContinuation
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderContinuation -> Maybe HeaderContinuation
forall a. a -> Maybe a
Just (HeaderContinuation -> IO ()) -> HeaderContinuation -> IO ()
forall a b. (a -> b) -> a -> b
$
        HeaderContinuation
            { hcStreamId :: Int
hcStreamId = Int
streamId
            , hcBlock :: PartialHeaderBlock
hcBlock = ByteString -> PartialHeaderBlock
newPartialHeaderBlock ByteString
frag
            , hcEndOfStream :: Bool
hcEndOfStream = Bool
endOfStream
            }

newPartialHeaderBlock :: HeaderBlockFragment -> PartialHeaderBlock
newPartialHeaderBlock :: ByteString -> PartialHeaderBlock
newPartialHeaderBlock ByteString
frag =
    PartialHeaderBlock
        { phbFragments :: [ByteString]
phbFragments = [ByteString
frag]
        , phbTotalSize :: Int
phbTotalSize = ByteString -> Int
BS.length ByteString
frag
        , phbNumFrames :: Int
phbNumFrames = Int
1
        }

addFragment
    :: StreamId
    -- ^ Used for error messages only
    -> HeaderBlockFragment
    -> PartialHeaderBlock
    -> IO PartialHeaderBlock
addFragment :: Int -> ByteString -> PartialHeaderBlock -> IO PartialHeaderBlock
addFragment Int
streamId ByteString
frag PartialHeaderBlock
phb = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PartialHeaderBlock -> Int
phbTotalSize PartialHeaderBlock
phb' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
headerFragmentLimit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"Header is too big"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PartialHeaderBlock -> Int
phbNumFrames PartialHeaderBlock
phb' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
continuationLimit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"Header is too fragmented"
    PartialHeaderBlock -> IO PartialHeaderBlock
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialHeaderBlock
phb'
  where
    phb' :: PartialHeaderBlock
phb' =
        PartialHeaderBlock
            { phbFragments :: [ByteString]
phbFragments = ByteString
frag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: PartialHeaderBlock -> [ByteString]
phbFragments PartialHeaderBlock
phb
            , phbTotalSize :: Int
phbTotalSize = PartialHeaderBlock -> Int
phbTotalSize PartialHeaderBlock
phb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
frag
            , phbNumFrames :: Int
phbNumFrames = PartialHeaderBlock -> Int
phbNumFrames PartialHeaderBlock
phb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            }

completeHeaderBlock :: PartialHeaderBlock -> HeaderBlockFragment
completeHeaderBlock :: PartialHeaderBlock -> ByteString
completeHeaderBlock = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (PartialHeaderBlock -> [ByteString])
-> PartialHeaderBlock
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> (PartialHeaderBlock -> [ByteString])
-> PartialHeaderBlock
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartialHeaderBlock -> [ByteString]
phbFragments