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

module Network.HTTP2.H2.Receiver (
    frameReceiver,
) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Short as Short
import Data.IORef
import Network.Control
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM

import Imports hiding (delete, insert)
import Network.HPACK
import Network.HPACK.Token
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

pingRateLimit :: Int
pingRateLimit :: StreamId
pingRateLimit = StreamId
4

settingsRateLimit :: Int
settingsRateLimit :: StreamId
settingsRateLimit = StreamId
4

emptyFrameRateLimit :: Int
emptyFrameRateLimit :: StreamId
emptyFrameRateLimit = StreamId
4

rstRateLimit :: Int
rstRateLimit :: StreamId
rstRateLimit = StreamId
4

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

frameReceiver :: Context -> Config -> IO ()
frameReceiver :: Context -> Config -> IO ()
frameReceiver ctx :: Context
ctx@Context{TVar StreamId
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
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 Stream)
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
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
..} conf :: Config
conf@Config{StreamId
Buffer
Manager
SockAddr
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
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: StreamId -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: StreamId
confWriteBuffer :: Buffer
..} = StreamId -> IO ()
loop StreamId
0 forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` SomeException -> IO ()
sendGoaway
  where
    loop :: Int -> IO ()
    loop :: StreamId -> IO ()
loop StreamId
n
        | StreamId
n forall a. Eq a => a -> a -> Bool
== StreamId
6 = do
            forall (m :: * -> *). MonadIO m => m ()
yield
            StreamId -> IO ()
loop StreamId
0
        | Bool
otherwise = do
            ByteString
hd <- StreamId -> IO ByteString
confReadN StreamId
frameHeaderLength
            if ByteString -> Bool
BS.null ByteString
hd
                then TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
ConnectionIsClosed
                else do
                    Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
conf forall a b. (a -> b) -> a -> b
$ ByteString -> (FrameType, FrameHeader)
decodeFrameHeader ByteString
hd
                    StreamId -> IO ()
loop (StreamId
n forall a. Num a => a -> a -> a
+ StreamId
1)

    sendGoaway :: SomeException -> IO ()
sendGoaway SomeException
se
        | Just e :: HTTP2Error
e@HTTP2Error
ConnectionIsClosed <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se =
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
e
        | Just e :: HTTP2Error
e@(ConnectionErrorIsReceived ErrorCode
_ StreamId
_ ReasonPhrase
_) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se =
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
e
        | Just e :: HTTP2Error
e@(ConnectionErrorIsSent ErrorCode
err StreamId
sid ReasonPhrase
msg) <- 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 forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame]
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
e
        | Just e :: HTTP2Error
e@(StreamErrorIsSent ErrorCode
err StreamId
sid ReasonPhrase
msg) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
            let frame :: ByteString
frame = ErrorCode -> StreamId -> ByteString
resetFrame ErrorCode
err StreamId
sid
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame]
            let frame' :: ByteString
frame' = StreamId -> ErrorCode -> ByteString -> ByteString
goawayFrame StreamId
sid ErrorCode
err forall a b. (a -> b) -> a -> b
$ ReasonPhrase -> ByteString
Short.fromShort ReasonPhrase
msg
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame']
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
e
        | Just e :: HTTP2Error
e@(StreamErrorIsReceived ErrorCode
err StreamId
sid) <- 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"
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame]
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
e
        -- this never happens
        | Just e :: HTTP2Error
e@(BadThingHappen SomeException
_) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se =
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish HTTP2Error
e
        | Bool
otherwise =
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ HTTP2Error -> Control
CFinish forall a b. (a -> b) -> a -> b
$ SomeException -> HTTP2Error
BadThingHappen SomeException
se

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

processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
_conf (FrameType
fid, FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId})
    | Context -> Bool
isServer Context
ctx
        Bool -> Bool -> Bool
&& StreamId -> Bool
isServerInitiated StreamId
streamId
        Bool -> Bool -> Bool
&& (FrameType
fid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameType
FramePriority, FrameType
FrameRSTStream, FrameType
FrameWindowUpdate]) =
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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 :: StreamId
streamId :: FrameHeader -> StreamId
streamId})
    | Context -> Bool
isServer Context
ctx =
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
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 Stream)
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
Manager
SockAddr
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: StreamId -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: StreamId
confWriteBuffer :: Buffer
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
..} (FrameType
ftyp, FrameHeader{StreamId
payloadLength :: FrameHeader -> StreamId
payloadLength :: StreamId
payloadLength, StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId})
    | FrameType
ftyp forall a. Ord a => a -> a -> Bool
> FrameType
maxFrameType = do
        Maybe StreamId
mx <- forall a. IORef a -> IO a
readIORef IORef (Maybe StreamId)
continued
        case Maybe StreamId
mx of
            Maybe StreamId
Nothing -> do
                -- ignoring unknown frame
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ StreamId -> IO ByteString
confReadN StreamId
payloadLength
            Just StreamId
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
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 Stream)
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
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) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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 :: Settings -> StreamId
maxFrameSize :: StreamId
maxFrameSize, Bool
enablePush :: Settings -> Bool
enablePush :: Bool
enablePush} = Settings
mySettings
                sid :: StreamId
sid = FrameHeader -> StreamId
streamId FrameHeader
header
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameHeader -> StreamId
payloadLength FrameHeader
header forall a. Ord a => a -> a -> Bool
> StreamId
maxFrameSize) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError StreamId
sid ReasonPhrase
"exceeds maximum frame size"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
enablePush Bool -> Bool -> Bool
&& FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
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 Stream)
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
Manager
SockAddr
StreamId -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: StreamId -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: StreamId
confWriteBuffer :: Buffer
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
..} FrameType
ftyp header :: FrameHeader
header@FrameHeader{StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId, StreamId
payloadLength :: StreamId
payloadLength :: FrameHeader -> StreamId
payloadLength}
    | StreamId -> Bool
isControl StreamId
streamId = do
        ByteString
bs <- StreamId -> IO ByteString
confReadN StreamId
payloadLength
        FrameType -> FrameHeader -> ByteString -> Context -> IO ()
control FrameType
ftyp FrameHeader
header ByteString
bs Context
ctx
    | FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise = do
        ByteString
bs <- StreamId -> IO ByteString
confReadN StreamId
payloadLength
        FrameHeader -> ByteString -> Context -> IO ()
push FrameHeader
header ByteString
bs Context
ctx
    | Bool
otherwise = do
        IO ()
checkContinued
        Maybe Stream
mstrm <- Context -> FrameType -> StreamId -> IO (Maybe Stream)
getStream Context
ctx FrameType
ftyp StreamId
streamId
        ByteString
bs <- StreamId -> IO ByteString
confReadN StreamId
payloadLength
        case Maybe Stream
mstrm of
            Just Stream
strm -> 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
                IO ()
resetContinued
                Bool
set <- StreamState -> Context -> Stream -> StreamId -> IO Bool
processState StreamState
state Context
ctx Stream
strm StreamId
streamId
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
set IO ()
setContinued
            Maybe Stream
Nothing
                | FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FramePriority -> do
                    -- for h2spec only
                    PriorityFrame Priority
newpri <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
                    Priority -> StreamId -> IO ()
checkPriority Priority
newpri StreamId
streamId
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    setContinued :: IO ()
setContinued = forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe StreamId)
continued forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just StreamId
streamId
    resetContinued :: IO ()
resetContinued = forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe StreamId)
continued forall a. Maybe a
Nothing
    checkContinued :: IO ()
checkContinued = do
        Maybe StreamId
mx <- forall a. IORef a -> IO a
readIORef IORef (Maybe StreamId)
continued
        case Maybe StreamId
mx of
            Maybe StreamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just StreamId
sid
                | StreamId
sid forall a. Eq a => a -> a -> Bool
== StreamId
streamId Bool -> Bool -> Bool
&& FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FrameContinuation -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise ->
                    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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 :: HeaderTable
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
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
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 Stream)
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
..} strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput} StreamId
streamId = do
    let mcl :: Maybe StreamId
mcl = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (StreamId, ByteString)
C8.readInt)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe StreamId
mcl (forall a. Eq a => a -> a -> Bool
/= (StreamId
0 :: Int))) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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"
    IORef (Maybe HeaderTable)
tlr <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    let inpObj :: InpObj
inpObj = HeaderTable
-> Maybe StreamId
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
tbl (forall a. a -> Maybe a
Just StreamId
0) (forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"") IORef (Maybe HeaderTable)
tlr
    if Context -> Bool
isServer Context
ctx
        then do
            let si :: ServerInfo
si = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
            forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue (ServerInfo -> TQueue (Input Stream)
inputQ ServerInfo
si) forall a b. (a -> b) -> a -> b
$ forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
        else forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (Either SomeException InpObj)
streamInput forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right InpObj
inpObj
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- Transition (process2)
processState (Open Maybe ClosedCode
hcl (HasBody tbl :: HeaderTable
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
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
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 Stream)
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
..} 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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (StreamId, ByteString)
C8.readInt)
    IORef StreamId
bodyLength <- forall a. a -> IO (IORef a)
newIORef StreamId
0
    IORef (Maybe HeaderTable)
tlr <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    TQueue (Either SomeException ByteString)
q <- forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (TQueue (Either SomeException ByteString)
-> Maybe StreamId
-> IORef StreamId
-> IORef (Maybe HeaderTable)
-> OpenState
Body TQueue (Either SomeException ByteString)
q Maybe StreamId
mcl IORef StreamId
bodyLength IORef (Maybe HeaderTable)
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)
-> (StreamId -> IO ()) -> IO Source
mkSource TQueue (Either SomeException ByteString)
q forall a b. (a -> b) -> a -> b
$ Context -> Stream -> StreamId -> IO ()
informWindowUpdate Context
ctx Stream
strm
    let inpObj :: InpObj
inpObj = HeaderTable
-> Maybe StreamId
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
tbl Maybe StreamId
mcl (Source -> IO ByteString
readSource Source
bodySource) IORef (Maybe HeaderTable)
tlr
    if Context -> Bool
isServer Context
ctx
        then do
            let si :: ServerInfo
si = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
            forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue (ServerInfo -> TQueue (Input Stream)
inputQ ServerInfo
si) forall a b. (a -> b) -> a -> b
$ forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
        else forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (Either SomeException InpObj)
streamInput forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right InpObj
inpObj
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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
    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
    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
    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
    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
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar StreamId
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef StreamId
peerStreamId :: IORef StreamId
myStreamId :: TVar StreamId
continued :: IORef (Maybe StreamId)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
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 Stream)
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
..} FrameType
ftyp StreamId
streamId
  | Bool
isEven    = TVar EvenStreamTable -> StreamId -> IO (Maybe Stream)
lookupEven TVar EvenStreamTable
evenStreamTable StreamId
streamId 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 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) forall a b. (a -> b) -> a -> b
$ do
        StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isReserved StreamState
st) forall a b. (a -> b) -> a -> b
$ Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
    forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getEvenStream Context
_ FrameType
_ Maybe Stream
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) forall a b. (a -> b) -> a -> b
$ do
        StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm0
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isHalfClosedRemote StreamState
st) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
StreamClosed
                    StreamId
streamId
                    ReasonPhrase
"header must not be sent to half or fully closed stream"
        -- Priority made an idle stream
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isIdle StreamState
st) forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
strm0
    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
        StreamId
csid <- Context -> IO StreamId
getPeerStreamID Context
ctx
        if StreamId
streamId forall a. Ord a => a -> a -> Bool
<= StreamId
csid -- consider the stream closed
            then
                if FrameType
ftyp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameType
FrameWindowUpdate, FrameType
FrameRSTStream, FrameType
FramePriority]
                    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- will be ignored
                    else
                        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                            ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                                ErrorCode
ProtocolError
                                StreamId
streamId
                                ReasonPhrase
"stream identifier must not decrease"
            else do
                -- consider the stream idle
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameType
FrameHeaders, FrameType
FramePriority]) 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 (forall a. Show a => a -> [Char]
show FrameType
ftyp))
                                )
                    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
errmsg
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) forall a b. (a -> b) -> a -> b
$ Context -> StreamId -> IO ()
setPeerStreamID Context
ctx StreamId
streamId
                -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit
                forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> StreamId -> FrameType -> IO Stream
openOddStreamCheck Context
ctx StreamId
streamId FrameType
ftyp
    | Bool
otherwise = forall a. HasCallStack => a
undefined -- never reach

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

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, StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
bs Context{IORef Bool
myFirstSettings :: IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, Rate
settingsRate :: Rate
settingsRate :: Context -> Rate
settingsRate, Settings
mySettings :: Settings
mySettings :: Context -> Settings
mySettings, IORef RxFlow
rxFlow :: IORef RxFlow
rxFlow :: Context -> IORef RxFlow
rxFlow} = do
    SettingsFrame SettingsList
peerAlist <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeSettingsFrame FrameHeader
header ByteString
bs
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
peerAlist
    if FrameFlags -> Bool
testAck FrameFlags
flags
        then do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SettingsList
peerAlist forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError StreamId
streamId ReasonPhrase
"ack settings has a body"
        else do
            -- Settings Flood - CVE-2019-9515
            StreamId
rate <- Rate -> IO StreamId
getRate Rate
settingsRate
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
rate forall a. Ord a => a -> a -> Bool
> StreamId
settingsRateLimit) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                    ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm StreamId
streamId ReasonPhrase
"too many settings"
            let ack :: ByteString
ack = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
setAck []
            Bool
sent <- forall a. IORef a -> IO a
readIORef IORef Bool
myFirstSettings
            if Bool
sent
                then do
                    let setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (forall a. a -> Maybe a
Just SettingsList
peerAlist) [ByteString
ack]
                    TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
                else do
                    -- Server side only
                    StreamId
connRxWS <- RxFlow -> StreamId
rxfWindow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef RxFlow
rxFlow
                    let frames :: [ByteString]
frames = Settings -> StreamId -> [ByteString]
makeNegotiationFrames Settings
mySettings StreamId
connRxWS
                        setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (forall a. a -> Maybe a
Just SettingsList
peerAlist) ([ByteString]
frames forall a. [a] -> [a] -> [a]
++ [ByteString
ack])
                    forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
myFirstSettings Bool
True
                    TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
control FrameType
FramePing FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags, StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
bs Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, Rate
pingRate :: Rate
pingRate :: Context -> Rate
pingRate} =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FrameFlags -> Bool
testAck FrameFlags
flags) forall a b. (a -> b) -> a -> b
$ do
        -- Ping Flood - CVE-2019-9512
        StreamId
rate <- Rate -> IO StreamId
getRate Rate
pingRate
        if StreamId
rate forall a. Ord a => a -> a -> Bool
> StreamId
pingRateLimit
            then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm StreamId
streamId ReasonPhrase
"too many ping"
            else do
                let frame :: ByteString
frame = ByteString -> ByteString
pingFrame ByteString
bs
                TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame]
control FrameType
FrameGoAway FrameHeader
header ByteString
bs Context
_ = do
    GoAwayFrame StreamId
sid ErrorCode
err ByteString
msg <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeGoAwayFrame FrameHeader
header ByteString
bs
    if ErrorCode
err forall a. Eq a => a -> a -> Bool
== ErrorCode
NoError
        then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
ConnectionIsClosed
        else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsReceived ErrorCode
err StreamId
sid forall a b. (a -> b) -> a -> b
$ ByteString -> ReasonPhrase
Short.toShort ByteString
msg
control FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
ctx = do
    WindowUpdateFrame StreamId
n <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Context -> StreamId -> IO ()
increaseConnectionWindowSize Context
ctx StreamId
n
control FrameType
_ FrameHeader
_ ByteString
_ Context
_ =
    -- must not reach here
    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 :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
bs Context
ctx = do
    PushPromiseFrame StreamId
sid ByteString
frag <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePushPromiseFrame FrameHeader
header ByteString
bs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StreamId -> Bool
isServerInitiated StreamId
sid) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
            ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                ErrorCode
ProtocolError
                StreamId
streamId
                ReasonPhrase
"push promise must specify an even stream identifier"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
frag forall a. Eq a => a -> a -> Bool
== ByteString
"") forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
            ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                ErrorCode
ProtocolError
                StreamId
streamId
                ReasonPhrase
"wrong header fragment for push promise"
    (TokenHeaderList
_, ValueTable
vt) <- ByteString -> StreamId -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
frag StreamId
streamId Context
ctx
    let ClientInfo{ByteString
authority :: ClientInfo -> ByteString
scheme :: ClientInfo -> ByteString
authority :: ByteString
scheme :: ByteString
..} = RoleInfo -> ClientInfo
toClientInfo forall a b. (a -> b) -> a -> b
$ Context -> RoleInfo
roleInfo Context
ctx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
        ( Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenAuthority ValueTable
vt forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
authority
            Bool -> Bool -> Bool
&& Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenScheme ValueTable
vt forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
scheme
        )
        forall a b. (a -> b) -> a -> b
$ do
            let mmethod :: Maybe ByteString
mmethod = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenMethod ValueTable
vt
                mpath :: Maybe ByteString
mpath = Token -> ValueTable -> Maybe ByteString
getHeaderValue 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 -> StreamId -> ByteString -> ByteString -> IO ()
openEvenStreamCacheCheck Context
ctx StreamId
sid ByteString
method ByteString
path
                (Maybe ByteString, Maybe ByteString)
_ -> 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) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec StreamId
sid ReasonPhrase
msg
    Right a
frame -> 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 forall a. Eq a => a -> a -> Bool
== StreamId
me =
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
me ReasonPhrase
"priority depends on itself"
    | Bool
otherwise = 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 :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags, StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
bs Context
ctx s :: StreamState
s@(Open Maybe ClosedCode
hcl OpenState
JustOpened) Stream{StreamId
streamNumber :: Stream -> StreamId
streamNumber :: StreamId
streamNumber} = do
    HeadersFrame Maybe Priority
mp ByteString
frag <- forall a. Either FrameDecodeError a -> IO a
guardIt 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 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
            StreamId
rate <- Rate -> IO StreamId
getRate forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
            if StreamId
rate forall a. Ord a => a -> a -> Bool
> StreamId
emptyFrameRateLimit
                then
                    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm StreamId
streamId ReasonPhrase
"too many empty headers"
                else forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
        else do
            case Maybe Priority
mp of
                Maybe Priority
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just Priority
p -> Priority -> StreamId -> IO ()
checkPriority Priority
p StreamId
streamNumber
            if Bool
endOfHeader
                then do
                    HeaderTable
tbl <- ByteString -> StreamId -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
frag StreamId
streamId Context
ctx
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                        if Bool
endOfStream
                            then -- turned into HalfClosedRemote in processState
                                Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (HeaderTable -> OpenState
NoBody HeaderTable
tbl)
                            else Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (HeaderTable -> OpenState
HasBody HeaderTable
tbl)
                else do
                    let siz :: StreamId
siz = ByteString -> StreamId
BS.length ByteString
frag
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl forall a b. (a -> b) -> a -> b
$ [ByteString] -> StreamId -> StreamId -> Bool -> OpenState
Continued [ByteString
frag] StreamId
siz StreamId
1 Bool
endOfStream

-- Transition (stream2)
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags, StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
bs Context
ctx (Open Maybe ClosedCode
_ (Body TQueue (Either SomeException ByteString)
q Maybe StreamId
_ IORef StreamId
_ IORef (Maybe HeaderTable)
tlr)) Stream
_ = do
    HeadersFrame Maybe Priority
_ ByteString
frag <- forall a. Either FrameDecodeError a -> IO a
guardIt 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
            HeaderTable
tbl <- ByteString -> StreamId -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
frag StreamId
streamId Context
ctx
            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe HeaderTable)
tlr (forall a. a -> Maybe a
Just HeaderTable
tbl)
            forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException ByteString)
q forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ByteString
""
            forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
        else -- we don't support continuation here.

            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    ErrorCode
ProtocolError
                    StreamId
streamId
                    ReasonPhrase
"continuation in trailer is not supported"

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

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

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

    -- The spec mandates (section 8.1):
    --
    -- > When this is true, a server MAY request that the client abort
    -- > transmission of a request without error by sending a RST_STREAM with an
    -- > error code of NO_ERROR after sending a complete response (i.e., a frame
    -- > with the END_STREAM flag).
    --
    -- We check the first part ("after sending a complete response") by checking
    -- the current stream state.
    case (StreamState
s, ErrorCode
err) of
        (StreamState
HalfClosedRemote, ErrorCode
NoError) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
        (StreamState, ErrorCode)
_otherwise -> do
            Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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 :: StreamId
streamNumber :: Stream -> StreamId
streamNumber} = do
    -- ignore
    -- Resource Loop - CVE-2019-9513
    PriorityFrame Priority
newpri <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
    Priority -> StreamId -> IO ()
checkPriority Priority
newpri StreamId
streamNumber
    forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- this ordering is important
stream FrameType
FrameContinuation FrameHeader{StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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 :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
_ Context
_ (Open Maybe ClosedCode
_ Continued{}) Stream
_ =
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
st
stream FrameType
FrameData FrameHeader{StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
StreamClosed StreamId
streamId forall a b. (a -> b) -> a -> b
$
            forall a. IsString a => [Char] -> a
fromString ([Char]
"illegal data frame for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show StreamId
streamId)
stream FrameType
x FrameHeader{StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ =
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
        ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
streamId forall a b. (a -> b) -> a -> b
$
            forall a. IsString a => [Char] -> a
fromString ([Char]
"illegal frame " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FrameType
x forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show StreamId
streamId)

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

-- | Type for input streaming.
data Source
    = Source
        (Int -> IO ())
        (TQueue (Either E.SomeException ByteString))
        (IORef ByteString)
        (IORef Bool)

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

readSource :: Source -> IO ByteString
readSource :: Source -> IO ByteString
readSource (Source StreamId -> IO ()
inform TQueue (Either SomeException ByteString)
q IORef ByteString
refBS IORef Bool
refEOF) = do
    Bool
eof <- forall a. IORef a -> IO a
readIORef IORef Bool
refEOF
    if Bool
eof
        then forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
        else do
            ByteString
bs <- IO ByteString
readBS
            let len :: StreamId
len = ByteString -> StreamId
BS.length ByteString
bs
            StreamId -> IO ()
inform StreamId
len
            forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
  where
    readBS :: IO ByteString
    readBS :: IO ByteString
readBS = do
        ByteString
bs0 <- forall a. IORef a -> IO a
readIORef IORef ByteString
refBS
        if ByteString
bs0 forall a. Eq a => a -> a -> Bool
== ByteString
""
            then do
                Either SomeException ByteString
mBS <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM a
readTQueue TQueue (Either SomeException ByteString)
q
                case Either SomeException ByteString
mBS of
                    Left SomeException
err -> do
                        forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
True
                        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
err
                    Right ByteString
bs -> do
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
bs forall a. Eq a => a -> a -> Bool
== ByteString
"") forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
True
                        forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
            else do
                forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
refBS ByteString
""
                forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs0