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

module Network.HTTP2.H2.Receiver (
    frameReceiver,
    closureClient,
    closureServer,
) 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 Network.Control
import Network.HTTP.Semantics

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 :: StreamId
continuationLimit = StreamId
10

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

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

frameReceiver :: Context -> Config -> IO ()
frameReceiver :: Context -> Config -> IO ()
frameReceiver Context
ctx conf :: Config
conf@Config{StreamId
Buffer
SockAddr
Manager
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: StreamId
confSendAll :: ByteString -> IO ()
confReadN :: StreamId -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> StreamId -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> StreamId
confWriteBuffer :: Config -> Buffer
..} = do
    [Char] -> IO ()
labelMe [Char]
"H2 receiver"
    IO ()
forall {b}. IO b
loop
  where
    loop :: IO b
loop = do
        -- If 'confReadN' is timeouted, an exception is thrown
        -- to destroy the thread trees.
        hd <- StreamId -> IO ByteString
confReadN StreamId
frameHeaderLength
        when (BS.null hd) $ E.throwIO ConnectionIsTimeout
        processFrame ctx conf $ decodeFrameHeader hd
        loop

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

processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
_conf (FrameType
fid, FrameHeader{StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId})
    | Context -> Bool
isServer Context
ctx
        Bool -> Bool -> Bool
&& StreamId -> Bool
isServerInitiated StreamId
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. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"stream id should be odd"
processFrame Context
ctx Config
_conf (FrameType
FramePushPromise, FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId})
    | Context -> Bool
isServer Context
ctx =
        HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"push promise is not allowed"
processFrame Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
DynamicTable
Rate
Settings
TQueue Control
TQueue Output
SockAddr
ThreadManager
RoleInfo
Role
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe StreamId)
myStreamId :: TVar StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue Output
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
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
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar StreamId
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
myStreamId :: Context -> TVar StreamId
continued :: Context -> IORef (Maybe StreamId)
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{StreamId
Buffer
SockAddr
Manager
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> StreamId -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> StreamId
confWriteBuffer :: Config -> Buffer
confWriteBuffer :: Buffer
confBufferSize :: StreamId
confSendAll :: ByteString -> IO ()
confReadN :: StreamId -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} (FrameType
ftyp, FrameHeader{StreamId
payloadLength :: StreamId
payloadLength :: FrameHeader -> StreamId
payloadLength, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId})
    | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Ord a => a -> a -> Bool
> FrameType
maxFrameType = do
        mx <- IORef (Maybe StreamId) -> IO (Maybe StreamId)
forall a. IORef a -> IO a
readIORef IORef (Maybe StreamId)
continued
        case mx of
            Maybe StreamId
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
$ StreamId -> IO ByteString
confReadN StreamId
payloadLength
            Just StreamId
_ -> HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"unknown frame"
processFrame ctx :: Context
ctx@Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
DynamicTable
Rate
Settings
TQueue Control
TQueue Output
SockAddr
ThreadManager
RoleInfo
Role
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
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar StreamId
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
myStreamId :: Context -> TVar StreamId
continued :: Context -> IORef (Maybe StreamId)
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 StreamId)
myStreamId :: TVar StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue Output
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
..} 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 StreamId
sid ReasonPhrase
msg) -> HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec StreamId
sid ReasonPhrase
msg
        Right (FrameType, FrameHeader)
_ -> do
            let Settings{StreamId
maxFrameSize :: StreamId
maxFrameSize :: Settings -> StreamId
maxFrameSize, Bool
enablePush :: Bool
enablePush :: Settings -> Bool
enablePush} = Settings
mySettings
                sid :: StreamId
sid = FrameHeader -> StreamId
streamId FrameHeader
header
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameHeader -> StreamId
payloadLength FrameHeader
header StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
maxFrameSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError StreamId
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. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
sid ReasonPhrase
"push not enabled"
            Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream Context
ctx Config
conf FrameType
ftyp FrameHeader
header

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

controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream ctx :: Context
ctx@Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
DynamicTable
Rate
Settings
TQueue Control
TQueue Output
SockAddr
ThreadManager
RoleInfo
Role
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
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar StreamId
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
myStreamId :: Context -> TVar StreamId
continued :: Context -> IORef (Maybe StreamId)
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 StreamId)
myStreamId :: TVar StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue Output
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
..} Config{StreamId
Buffer
SockAddr
Manager
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> StreamId -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> StreamId
confWriteBuffer :: Config -> Buffer
confWriteBuffer :: Buffer
confBufferSize :: StreamId
confSendAll :: ByteString -> IO ()
confReadN :: StreamId -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} FrameType
ftyp header :: FrameHeader
header@FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId, StreamId
payloadLength :: FrameHeader -> StreamId
payloadLength :: StreamId
payloadLength}
    | StreamId -> Bool
isControl StreamId
streamId = do
        bs <- StreamId -> IO ByteString
confReadN StreamId
payloadLength
        control ftyp header bs ctx
    | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise = do
        bs <- StreamId -> IO ByteString
confReadN StreamId
payloadLength
        push header bs ctx
    | Bool
otherwise = do
        IO ()
checkContinued
        mstrm <- Context -> FrameType -> StreamId -> IO (Maybe Stream)
getStream Context
ctx FrameType
ftyp StreamId
streamId
        bs <- confReadN payloadLength
        case mstrm of
            Just Stream
strm -> do
                state0 <- Stream -> IO StreamState
readStreamState Stream
strm
                state <- stream ftyp header bs ctx state0 strm
                resetContinued
                set <- processState state ctx strm streamId
                when set setContinued
            Maybe Stream
Nothing
                | FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePriority -> do
                    -- for h2spec only
                    PriorityFrame 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
                    checkPriority newpri streamId
                | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    setContinued :: IO ()
setContinued = IORef (Maybe StreamId) -> Maybe StreamId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe StreamId)
continued (Maybe StreamId -> IO ()) -> Maybe StreamId -> IO ()
forall a b. (a -> b) -> a -> b
$ StreamId -> Maybe StreamId
forall a. a -> Maybe a
Just StreamId
streamId
    resetContinued :: IO ()
resetContinued = IORef (Maybe StreamId) -> Maybe StreamId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe StreamId)
continued Maybe StreamId
forall a. Maybe a
Nothing
    checkContinued :: IO ()
checkContinued = do
        mx <- IORef (Maybe StreamId) -> IO (Maybe StreamId)
forall a. IORef a -> IO a
readIORef IORef (Maybe StreamId)
continued
        case mx of
            Maybe StreamId
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just StreamId
sid
                | StreamId
sid StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
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. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"continuation frame must follow"

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

processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool
-- Transition (process1)
processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool
processState (Open Maybe ClosedCode
_ (NoBody tbl :: TokenHeaderTable
tbl@(TokenHeaderList
_, ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
DynamicTable
Rate
Settings
TQueue Control
TQueue Output
SockAddr
ThreadManager
RoleInfo
Role
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
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar StreamId
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
myStreamId :: Context -> TVar StreamId
continued :: Context -> IORef (Maybe StreamId)
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 StreamId)
myStreamId :: TVar StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue Output
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
..} strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput} StreamId
streamId = do
    let mcl :: Maybe StreamId
mcl = (StreamId, ByteString) -> StreamId
forall a b. (a, b) -> a
fst ((StreamId, ByteString) -> StreamId)
-> Maybe (StreamId, ByteString) -> Maybe StreamId
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 (StreamId, ByteString))
-> Maybe (StreamId, 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 (StreamId, ByteString)
C8.readInt)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe StreamId -> (StreamId -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe StreamId
mcl (StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= (StreamId
0 :: Int))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
                ErrorCode
ProtocolError
                StreamId
streamId
                ReasonPhrase
"no body but content-length is not zero"
    tlr <- Maybe TokenHeaderTable -> IO (IORef (Maybe TokenHeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe TokenHeaderTable
forall a. Maybe a
Nothing
    let inpObj = TokenHeaderTable
-> Maybe StreamId
-> InpBody
-> IORef (Maybe TokenHeaderTable)
-> InpObj
InpObj TokenHeaderTable
tbl (StreamId -> Maybe StreamId
forall a. a -> Maybe a
Just StreamId
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 isServer ctx
        then do
            let ServerInfo{..} = toServerInfo roleInfo
            launch ctx strm inpObj
        else putMVar streamInput $ Right inpObj
    halfClosedRemote ctx strm
    return False

-- Transition (process2)
processState (Open Maybe ClosedCode
hcl (HasBody tbl :: TokenHeaderTable
tbl@(TokenHeaderList
_, ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
DynamicTable
Rate
Settings
TQueue Control
TQueue Output
SockAddr
ThreadManager
RoleInfo
Role
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
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar StreamId
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
myStreamId :: Context -> TVar StreamId
continued :: Context -> IORef (Maybe StreamId)
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 StreamId)
myStreamId :: TVar StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue Output
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
..} strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput, IORef (Maybe RxQ)
streamRxQ :: IORef (Maybe RxQ)
streamRxQ :: Stream -> IORef (Maybe RxQ)
streamRxQ} StreamId
_streamId = do
    let mcl :: Maybe StreamId
mcl = (StreamId, ByteString) -> StreamId
forall a b. (a, b) -> a
fst ((StreamId, ByteString) -> StreamId)
-> Maybe (StreamId, ByteString) -> Maybe StreamId
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 (StreamId, ByteString))
-> Maybe (StreamId, 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 (StreamId, ByteString)
C8.readInt)
    bodyLength <- StreamId -> IO (IORef StreamId)
forall a. a -> IO (IORef a)
newIORef StreamId
0
    tlr <- newIORef Nothing
    q <- newTQueueIO
    writeIORef streamRxQ $ Just q
    setStreamState ctx strm $ Open hcl (Body q mcl bodyLength tlr)
    -- FLOW CONTROL: WINDOW_UPDATE 0: recv: announcing my limit properly
    -- FLOW CONTROL: WINDOW_UPDATE: recv: announcing my limit properly
    bodySource <- mkSource q $ informWindowUpdate ctx strm
    let inpObj = TokenHeaderTable
-> Maybe StreamId
-> InpBody
-> IORef (Maybe TokenHeaderTable)
-> InpObj
InpObj TokenHeaderTable
tbl Maybe StreamId
mcl (Source -> InpBody
readSource Source
bodySource) IORef (Maybe TokenHeaderTable)
tlr
    if isServer ctx
        then do
            let ServerInfo{..} = toServerInfo roleInfo
            launch ctx strm inpObj
        else putMVar streamInput $ Right inpObj
    return False

-- Transition (process3)
processState s :: StreamState
s@(Open Maybe ClosedCode
_ Continued{}) Context
ctx Stream
strm StreamId
_streamId = do
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- Transition (process4)
processState StreamState
HalfClosedRemote Context
ctx Stream
strm StreamId
_streamId = do
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- Transition (process5)
processState (Closed ClosedCode
cc) Context
ctx Stream
strm StreamId
_streamId = do
    Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- Transition (process6)
processState StreamState
s Context
ctx Stream
strm StreamId
_streamId = do
    -- Idle, Open Body, Closed
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

{- FOURMOLU_DISABLE -}
getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream)
getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream)
getStream ctx :: Context
ctx@Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
DynamicTable
Rate
Settings
TQueue Control
TQueue Output
SockAddr
ThreadManager
RoleInfo
Role
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
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar StreamId
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
myStreamId :: Context -> TVar StreamId
continued :: Context -> IORef (Maybe StreamId)
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 StreamId)
myStreamId :: TVar StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue Output
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
..} FrameType
ftyp StreamId
streamId
  | Bool
isEven    = TVar EvenStreamTable -> StreamId -> IO (Maybe Stream)
lookupEven TVar EvenStreamTable
evenStreamTable StreamId
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 -> StreamId -> IO (Maybe Stream)
lookupOdd TVar OddStreamTable
oddStreamTable  StreamId
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 -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getOddStream  Context
ctx FrameType
ftyp StreamId
streamId
  where
    isEven :: Bool
isEven = StreamId -> Bool
isServerInitiated StreamId
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
        st <- Stream -> IO StreamState
readStreamState Stream
strm
        when (isReserved st) $ halfClosedLocal ctx strm 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 -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getOddStream Context
ctx FrameType
ftyp StreamId
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
        st <- Stream -> IO StreamState
readStreamState Stream
strm0
        when (isHalfClosedRemote st) $
            E.throwIO $
                ConnectionErrorIsSent
                    StreamClosed
                    streamId
                    "header must not be sent to half or fully closed stream"
        -- Priority made an idle stream
        when (isIdle st) $ opened ctx 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 StreamId
streamId Maybe Stream
Nothing
    | Context -> Bool
isServer Context
ctx = do
        csid <- Context -> IO StreamId
getPeerStreamID Context
ctx
        if streamId <= csid -- consider the stream closed
            then
                if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority]
                    then return Nothing -- will be ignored
                    else
                        E.throwIO $
                            ConnectionErrorIsSent
                                ProtocolError
                                streamId
                                "stream identifier must not decrease"
            else do
                -- consider the stream idle
                when (ftyp `notElem` [FrameHeaders, FramePriority]) $ do
                    let 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)
                                )
                    E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg
                when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId
                -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit
                Just <$> openOddStreamCheck ctx streamId 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 :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context{IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings :: IORef Bool
myFirstSettings, TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
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 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
    traverse_ E.throwIO $ checkSettingsList peerAlist
    if testAck flags
        then do
            when (peerAlist /= []) $
                E.throwIO $
                    ConnectionErrorIsSent FrameSizeError streamId "ack settings has a body"
        else do
            -- Settings Flood - CVE-2019-9515
            rate <- getRate settingsRate
            when (rate > settingsRateLimit mySettings) $
                E.throwIO $
                    ConnectionErrorIsSent EnhanceYourCalm streamId "too many settings"
            let ack = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
setAck []
            sent <- readIORef myFirstSettings
            if sent
                then do
                    let setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (SettingsList -> Maybe SettingsList
forall a. a -> Maybe a
Just SettingsList
peerAlist) [ByteString
ack]
                    enqueueControl controlQ setframe
                else do
                    -- Server side only
                    connRxWS <- rxfBufSize <$> readIORef rxFlow
                    let frames = Settings -> StreamId -> [ByteString]
makeNegotiationFrames Settings
mySettings StreamId
connRxWS
                        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])
                    writeIORef myFirstSettings True
                    enqueueControl controlQ setframe
control FrameType
FramePing FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context{Settings
mySettings :: Context -> Settings
mySettings :: Settings
mySettings, TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ, 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
        rate <- Rate -> IO StreamId
getRate Rate
pingRate
        if rate > pingRateLimit mySettings
            then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many ping"
            else do
                let frame = ByteString -> ByteString
pingFrame ByteString
bs
                enqueueControl controlQ $ CFrames Nothing [frame]
control FrameType
FrameGoAway FrameHeader
header ByteString
bs Context
_ = do
    GoAwayFrame sid err 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 err == NoError
        then E.throwIO ConnectionIsClosed
        else E.throwIO $ ConnectionErrorIsReceived err sid $ Short.toShort msg
control FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
ctx = do
    WindowUpdateFrame 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
    increaseConnectionWindowSize ctx 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{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx = do
    PushPromiseFrame sid 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
    unless (isServerInitiated sid) $
        E.throwIO $
            ConnectionErrorIsSent
                ProtocolError
                streamId
                "push promise must specify an even stream identifier"
    when (frag == "") $
        E.throwIO $
            ConnectionErrorIsSent
                ProtocolError
                streamId
                "wrong header fragment for push promise"
    (_, vt) <- hpackDecodeHeader frag streamId ctx
    let ClientInfo{..} = toClientInfo $ roleInfo ctx
    when
        ( getFieldValue tokenAuthority vt == Just (UTF8.fromString authority)
            && getFieldValue tokenScheme vt == Just scheme
        )
        $ do
            let mmethod = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenMethod ValueTable
vt
                mpath = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenPath ValueTable
vt
            case (mmethod, mpath) of
                (Just ByteString
method, Just ByteString
path) ->
                    -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit
                    Context -> StreamId -> ByteString -> ByteString -> IO ()
openEvenStreamCacheCheck Context
ctx StreamId
sid ByteString
method ByteString
path
                (Maybe ByteString, Maybe ByteString)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

{-# 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 StreamId
sid ReasonPhrase
msg) -> HTTP2Error -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec StreamId
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 -> StreamId -> IO ()
checkPriority Priority
p StreamId
me
    | StreamId
dep StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
me =
        HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
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 :: StreamId
dep = Priority -> StreamId
streamDependency Priority
p

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, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx s :: StreamState
s@(Open Maybe ClosedCode
hcl OpenState
JustOpened) Stream{StreamId
streamNumber :: StreamId
streamNumber :: Stream -> StreamId
streamNumber} = do
    HeadersFrame mp 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 = FrameFlags -> Bool
testEndStream FrameFlags
flags
        endOfHeader = FrameFlags -> Bool
testEndHeader FrameFlags
flags
    if frag == "" && not endOfStream && not endOfHeader
        then do
            -- Empty Frame Flooding - CVE-2019-9518
            rate <- getRate $ emptyFrameRate ctx
            if rate > emptyFrameRateLimit (mySettings ctx)
                then
                    E.throwIO $
                        ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty headers"
                else return s
        else do
            case mp of
                Maybe Priority
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just Priority
p -> Priority -> StreamId -> IO ()
checkPriority Priority
p StreamId
streamNumber
            if endOfHeader
                then do
                    tbl <- hpackDecodeHeader frag streamId ctx
                    return $
                        if endOfStream
                            then -- turned into HalfClosedRemote in processState
                                Open hcl (NoBody tbl)
                            else Open hcl (HasBody tbl)
                else do
                    let siz = ByteString -> StreamId
BS.length ByteString
frag
                    return $ Open hcl $ Continued [frag] siz 1 endOfStream

-- Transition (stream2)
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx (Open Maybe ClosedCode
_ (Body RxQ
q Maybe StreamId
_ IORef StreamId
_ IORef (Maybe TokenHeaderTable)
tlr)) Stream
_ = do
    HeadersFrame _ 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 = FrameFlags -> Bool
testEndStream FrameFlags
flags
    -- checking frag == "" is not necessary
    if endOfStream
        then do
            tbl <- hpackDecodeTrailer frag streamId ctx
            writeIORef tlr (Just tbl)
            atomically $ writeTQueue q $ Right (mempty, True)
            return HalfClosedRemote
        else -- we don't support continuation here.
            E.throwIO $
                ConnectionErrorIsSent
                    ProtocolError
                    streamId
                    "continuation in trailer is not supported"

-- Transition (stream4)
stream
    FrameType
FrameData
    header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, StreamId
payloadLength :: FrameHeader -> StreamId
payloadLength :: StreamId
payloadLength, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId}
    ByteString
bs
    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 RxQ
q Maybe StreamId
mcl IORef StreamId
bodyLength IORef (Maybe TokenHeaderTable)
_))
    Stream{StreamId
TVar TxFlow
IORef (Maybe RxQ)
IORef RxFlow
IORef StreamState
MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamRxQ :: Stream -> IORef (Maybe RxQ)
streamNumber :: Stream -> StreamId
streamNumber :: StreamId
streamState :: IORef StreamState
streamInput :: MVar (Either SomeException InpObj)
streamTxFlow :: TVar TxFlow
streamRxFlow :: IORef RxFlow
streamRxQ :: IORef (Maybe RxQ)
streamRxFlow :: Stream -> IORef RxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamState :: Stream -> IORef StreamState
..} = do
        DataFrame 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
        okc <- atomicModifyIORef' rxFlow $ checkRxLimit payloadLength
        unless okc $
            E.throwIO $
                ConnectionErrorIsSent
                    EnhanceYourCalm
                    streamId
                    "exceeds connection flow-control limit"
        -- FLOW CONTROL: WINDOW_UPDATE: recv: rejecting if over my limit
        oks <- atomicModifyIORef' streamRxFlow $ checkRxLimit payloadLength
        unless oks $
            E.throwIO $
                ConnectionErrorIsSent
                    EnhanceYourCalm
                    streamId
                    "exceeds stream flow-control limit"
        len0 <- readIORef bodyLength
        let len = StreamId
len0 StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
payloadLength
            endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
        -- Empty Frame Flooding - CVE-2019-9518
        if body == ""
            then unless endOfStream $ do
                rate <- getRate emptyFrameRate
                when (rate > emptyFrameRateLimit mySettings) $ do
                    E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty data"
            else do
                writeIORef bodyLength len
                atomically $ writeTQueue q $ Right (body, endOfStream)
        if endOfStream
            then do
                case mcl of
                    Maybe StreamId
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just StreamId
cl ->
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
cl StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= StreamId
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                                ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
                                    ErrorCode
ProtocolError
                                    StreamId
streamId
                                    ReasonPhrase
"actual body length is not the same as content-length"
                -- no trailers
                atomically $ writeTQueue q $ Right (mempty, True)
                return HalfClosedRemote
            else return s

-- Transition (stream5)
stream FrameType
FrameContinuation FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags, StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
frag Context
ctx s :: StreamState
s@(Open Maybe ClosedCode
hcl (Continued [ByteString]
rfrags StreamId
siz StreamId
n Bool
endOfStream)) Stream
_ = do
    let 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
endOfHeader
        then do
            -- Empty Frame Flooding - CVE-2019-9518
            rate <- Rate -> IO StreamId
getRate (Rate -> IO StreamId) -> Rate -> IO StreamId
forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
            if rate > emptyFrameRateLimit (mySettings ctx)
                then
                    E.throwIO $
                        ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation"
                else return s
        else do
            let rfrags' :: [ByteString]
rfrags' = ByteString
frag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
rfrags
                siz' :: StreamId
siz' = StreamId
siz StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ ByteString -> StreamId
BS.length ByteString
frag
                n' :: StreamId
n' = StreamId
n StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
1
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
siz' StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
headerFragmentLimit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm StreamId
streamId ReasonPhrase
"Header is too big"
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
n' StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
continuationLimit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm StreamId
streamId ReasonPhrase
"Header is too fragmented"
            if Bool
endOfHeader
                then do
                    let hdrblk :: ByteString
hdrblk = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
rfrags'
                    tbl <- ByteString -> StreamId -> Context -> IO TokenHeaderTable
hpackDecodeHeader ByteString
hdrblk StreamId
streamId Context
ctx
                    return $
                        if endOfStream
                            then -- turned into HalfClosedRemote in processState
                                Open hcl (NoBody tbl)
                            else Open hcl (HasBody tbl)
                else 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 -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString] -> StreamId -> StreamId -> Bool -> OpenState
Continued [ByteString]
rfrags' StreamId
siz' StreamId
n' Bool
endOfStream

-- (No state transition)
stream FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
_ StreamState
s Stream
strm = do
    WindowUpdateFrame 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
    increaseStreamWindowSize strm n
    return s

-- Transition (stream6)
stream FrameType
FrameRSTStream header :: FrameHeader
header@FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx StreamState
s Stream
strm = do
    -- Rapid Rest: CVE-2023-44487
    rate <- Rate -> IO StreamId
getRate (Rate -> IO StreamId) -> Rate -> IO StreamId
forall a b. (a -> b) -> a -> b
$ Context -> Rate
rstRate Context
ctx
    when (rate > rstRateLimit (mySettings ctx)) $
        E.throwIO $
            ConnectionErrorIsSent EnhanceYourCalm streamId "too many rst_stream"
    RSTStreamFrame err <- guardIt $ decodeRSTStreamFrame header bs
    let cc = ErrorCode -> ClosedCode
Reset ErrorCode
err
    closed ctx strm 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 two non-error cases, below. (Section 8.1 of the spec
    -- is also relevant, but it is less explicit about the /either endpoint/
    -- part.)
    case s of
        Open Maybe ClosedCode
_ OpenState
_
            | ErrorCode -> Bool
isNonCritical ErrorCode
err ->
                -- Open /or/ half-closed (local)
                StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        StreamState
HalfClosedRemote
            | ErrorCode -> Bool
isNonCritical ErrorCode
err ->
                StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        StreamState
_otherwise -> do
            HTTP2Error -> IO StreamState
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> HTTP2Error
StreamErrorIsReceived ErrorCode
err StreamId
streamId
-- (No state transition)
stream FrameType
FramePriority FrameHeader
header ByteString
bs Context
_ StreamState
s Stream{StreamId
streamNumber :: Stream -> StreamId
streamNumber :: StreamId
streamNumber} = do
    -- ignore
    -- Resource Loop - CVE-2019-9513
    PriorityFrame 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
    checkPriority newpri streamNumber
    return s

-- this ordering is important
stream FrameType
FrameContinuation FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    HTTP2Error -> IO StreamState
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"continue frame cannot come here"
stream FrameType
_ FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ (Open Maybe ClosedCode
_ Continued{}) Stream
_ =
    HTTP2Error -> IO StreamState
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
            ErrorCode
ProtocolError
            StreamId
streamId
            ReasonPhrase
"an illegal frame follows header/continuation frames"
-- Ignore frames to streams we have just reset, per section 5.1.
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{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    HTTP2Error -> IO StreamState
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
StreamClosed StreamId
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]
++ StreamId -> [Char]
forall a. Show a => a -> [Char]
show StreamId
streamId)
stream FrameType
x FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    HTTP2Error -> IO StreamState
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$
        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
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]
++ StreamId -> [Char]
forall a. Show a => a -> [Char]
show StreamId
streamId)

{- FOURMOLU_DISABLE -}
-- Although some stream errors indicate misbehaving peers, such as
-- FLOW_CONTROL_ERROR, not all errors do. We will close the connection only
-- for critical errors.
isNonCritical :: ErrorCode -> Bool
isNonCritical :: ErrorCode -> Bool
isNonCritical ErrorCode
NoError       = Bool
True
isNonCritical ErrorCode
Cancel        = Bool
True
isNonCritical ErrorCode
InternalError = Bool
True
isNonCritical ErrorCode
_             = Bool
False
{- FOURMOLU_ENABLE -}

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

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

mkSource :: RxQ -> (Int -> IO ()) -> IO Source
mkSource :: RxQ -> (StreamId -> IO ()) -> IO Source
mkSource RxQ
q StreamId -> IO ()
inform = RxQ -> (StreamId -> IO ()) -> IORef Bool -> Source
Source RxQ
q StreamId -> 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 RxQ
q StreamId -> IO ()
inform IORef Bool
refEOF) = do
    eof <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
refEOF
    if eof
        then return (mempty, True)
        else do
            mBS <- atomically $ readTQueue q
            case 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. (HasCallStack, 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 :: StreamId
len = ByteString -> StreamId
BS.length ByteString
bs
                    StreamId -> IO ()
inform StreamId
len
                    (ByteString, Bool) -> InpBody
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, Bool
isEOF)

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

closureClient :: Config -> Either E.SomeException a -> IO a
closureClient :: forall a. Config -> Either SomeException a -> IO a
closureClient Config{StreamId
Buffer
SockAddr
Manager
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> StreamId -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> StreamId
confWriteBuffer :: Config -> Buffer
confWriteBuffer :: Buffer
confBufferSize :: StreamId
confSendAll :: ByteString -> IO ()
confReadN :: StreamId -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} (Right a
x) = do
    let frame :: ByteString
frame = StreamId -> ErrorCode -> ByteString -> ByteString
goawayFrame StreamId
0 ErrorCode
NoError ByteString
""
    ByteString -> IO ()
confSendAll ByteString
frame IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
ignore
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where
    ignore :: SomeException -> IO ()
ignore (E.SomeException e
e)
        | e -> Bool
forall e. Exception e => e -> Bool
isAsyncException e
e = e -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO e
e
        | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
closureClient Config
conf (Left SomeException
se) = Config -> SomeException -> IO a
forall a. Config -> SomeException -> IO a
closureServer Config
conf SomeException
se

closureServer :: Config -> E.SomeException -> IO a
closureServer :: forall a. Config -> SomeException -> IO a
closureServer Config{StreamId
Buffer
SockAddr
Manager
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> StreamId -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> StreamId
confWriteBuffer :: Config -> Buffer
confWriteBuffer :: Buffer
confBufferSize :: StreamId
confSendAll :: ByteString -> IO ()
confReadN :: StreamId -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} SomeException
se
    | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
se = SomeException -> IO a
forall e a. (HasCallStack, 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
        HTTP2Error -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO HTTP2Error
ConnectionIsClosed
    | Just e :: HTTP2Error
e@(ConnectionErrorIsReceived{}) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se =
        HTTP2Error -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO HTTP2Error
e
    | Just e :: HTTP2Error
e@(ConnectionErrorIsSent ErrorCode
err StreamId
sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        let frame :: ByteString
frame = StreamId -> ErrorCode -> ByteString -> ByteString
goawayFrame StreamId
sid ErrorCode
err (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
        ByteString -> IO ()
confSendAll ByteString
frame
        HTTP2Error -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO HTTP2Error
e
    | Just e :: HTTP2Error
e@(StreamErrorIsSent ErrorCode
err StreamId
sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        let frame :: ByteString
frame = ErrorCode -> StreamId -> ByteString
resetFrame ErrorCode
err StreamId
sid
        let frame' :: ByteString
frame' = StreamId -> ErrorCode -> ByteString -> ByteString
goawayFrame StreamId
sid ErrorCode
err (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
        ByteString -> IO ()
confSendAll (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
frame ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
frame'
        HTTP2Error -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO HTTP2Error
e
    | Just e :: HTTP2Error
e@(StreamErrorIsReceived ErrorCode
err StreamId
sid) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
        let frame :: ByteString
frame = StreamId -> ErrorCode -> ByteString -> ByteString
goawayFrame StreamId
sid ErrorCode
err ByteString
"treat a stream error as a connection error"
        ByteString -> IO ()
confSendAll ByteString
frame
        HTTP2Error -> IO a
forall e a. (HasCallStack, 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. (HasCallStack, Exception e) => e -> IO a
E.throwIO SomeException
se
    | Bool
otherwise = HTTP2Error -> IO a
forall e a. (HasCallStack, 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