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

module Network.HTTP2.Arch.Receiver (
    frameReceiver
  , maxConcurrency
  , myInitialAlist
  , initialFrames
  ) 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 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.Arch.Config
import Network.HTTP2.Arch.Context
import Network.HTTP2.Arch.EncodeFrame
import Network.HTTP2.Arch.HPACK
import Network.HTTP2.Arch.Queue
import Network.HTTP2.Arch.Rate
import Network.HTTP2.Arch.Stream
import Network.HTTP2.Arch.Types
import Network.HTTP2.Frame

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

maxConcurrency :: Int
maxConcurrency :: Int
maxConcurrency = Int
recommendedConcurrency

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

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

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

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

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

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

initialFrames :: SettingsList -> [ByteString]
initialFrames :: SettingsList -> [ByteString]
initialFrames SettingsList
alist = [ByteString
frame1,ByteString
frame2]
  where
    frame1 :: ByteString
frame1 = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame forall a. a -> a
id SettingsList
alist
    frame2 :: ByteString
frame2 = Int -> Int -> ByteString
windowUpdateFrame Int
0 (Int
maxWindowSize forall a. Num a => a -> a -> a
- Int
defaultWindowSize)

myInitialAlist :: Config -> SettingsList
myInitialAlist :: Config -> SettingsList
myInitialAlist Config{Int
Buffer
Manager
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
..} =
    -- confBufferSize is the size of the write buffer.
    -- But we assume that the size of the read buffer is the same size.
    -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE.
    [(SettingsKey
SettingsMaxFrameSize,Int
payloadLen)
    ,(SettingsKey
SettingsMaxConcurrentStreams,Int
maxConcurrency)
    ,(SettingsKey
SettingsInitialWindowSize,Int
maxWindowSize)]
  where
    len :: Int
len = Int
confBufferSize forall a. Num a => a -> a -> a
- Int
frameHeaderLength
    payloadLen :: Int
payloadLen = forall a. Ord a => a -> a -> a
max Int
defaultPayloadLength Int
len

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

frameReceiver :: Context -> Config -> IO ()
frameReceiver :: Context -> Config -> IO ()
frameReceiver ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
..} conf :: Config
conf@Config{Int
Buffer
Manager
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} = Int -> IO ()
loop Int
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 :: Int -> IO ()
loop Int
n
      | Int
n forall a. Eq a => a -> a -> Bool
== Int
6 = do
          forall (m :: * -> *). MonadIO m => m ()
yield
          Int -> IO ()
loop Int
0
      | Bool
otherwise = do
        ByteString
hd <- Int -> IO ByteString
confReadN Int
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
            Int -> IO ()
loop (Int
n forall a. Num a => a -> a -> a
+ Int
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
_ Int
_ 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 Int
sid ReasonPhrase
msg) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
          let frame :: ByteString
frame = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
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 Int
sid) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
          let frame :: ByteString
frame = ErrorCode -> Int -> ByteString
resetFrame ErrorCode
err Int
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' = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
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
      | Just e :: HTTP2Error
e@(StreamErrorIsReceived ErrorCode
err Int
sid) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
          let frame :: ByteString
frame = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
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{Int
streamId :: FrameHeader -> Int
streamId :: Int
streamId})
  | Context -> Bool
isServer Context
ctx Bool -> Bool -> Bool
&&
    Int -> Bool
isServerInitiated Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"stream id should be odd"

processFrame Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Config{Int
Buffer
Manager
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} (FrameType
ftyp, FrameHeader{Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId})
  | FrameType
ftyp forall a. Ord a => a -> a -> Bool
> FrameType
maxFrameType = do
    Maybe Int
mx <- forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
continued
    case Maybe Int
mx of
        Maybe Int
Nothing -> do
            -- ignoring unknown frame
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString
confReadN Int
payloadLength
        Just Int
_  -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"unknown frame"
processFrame Context
ctx Config{Int
Buffer
Manager
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} (FrameType
FramePushPromise, header :: FrameHeader
header@FrameHeader{Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength,Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"push promise is not allowed"
  | Bool
otherwise = do
      ByteString
pl <- Int -> IO ByteString
confReadN Int
payloadLength
      PushPromiseFrame Int
sid ByteString
frag <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePushPromiseFrame FrameHeader
header ByteString
pl
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
isServerInitiated Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"wrong sid for push promise"
      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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"wrong header fragment for push promise"
      (TokenHeaderList
_,ValueTable
vt) <- ByteString -> Int -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
frag Int
streamId Context
ctx
      let ClientInfo{IORef (Cache (ByteString, ByteString) Stream)
ByteString
cache :: ClientInfo -> IORef (Cache (ByteString, ByteString) Stream)
authority :: ClientInfo -> ByteString
scheme :: ClientInfo -> ByteString
cache :: IORef (Cache (ByteString, ByteString) Stream)
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) -> do
                Stream
strm <- Context -> Int -> FrameType -> IO Stream
openStream Context
ctx Int
sid FrameType
FramePushPromise
                ByteString -> ByteString -> Stream -> RoleInfo -> IO ()
insertCache ByteString
method ByteString
path Stream
strm forall a b. (a -> b) -> a -> b
$ Context -> RoleInfo
roleInfo Context
ctx
            (Maybe ByteString, Maybe ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
processFrame ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
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
    Settings
settings <- forall a. IORef a -> IO a
readIORef IORef Settings
mySettings
    case Settings
-> (FrameType, FrameHeader)
-> Either FrameDecodeError (FrameType, FrameHeader)
checkFrameHeader Settings
settings (FrameType, FrameHeader)
typhdr of
      Left (FrameDecodeError ErrorCode
ec Int
sid ReasonPhrase
msg) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec Int
sid ReasonPhrase
msg
      Right (FrameType, FrameHeader)
_    -> 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 Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} conf :: Config
conf@Config{Int
Buffer
Manager
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} FrameType
ftyp header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId, Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}
  | Int -> Bool
isControl Int
streamId = do
      ByteString
pl <- Int -> IO ByteString
confReadN Int
payloadLength
      FrameType
-> FrameHeader -> ByteString -> Context -> Config -> IO ()
control FrameType
ftyp FrameHeader
header ByteString
pl Context
ctx Config
conf
  | Bool
otherwise = do
      IO ()
checkContinued
      Maybe Stream
mstrm <- Context -> FrameType -> Int -> IO (Maybe Stream)
getStream Context
ctx FrameType
ftyp Int
streamId
      ByteString
pl <- Int -> IO ByteString
confReadN Int
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
pl Context
ctx StreamState
state0 Stream
strm
            IO ()
resetContinued
            Bool
set <- StreamState -> Context -> Stream -> Int -> IO Bool
processState StreamState
state Context
ctx Stream
strm Int
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
pl
                Priority -> Int -> IO ()
checkPriority Priority
newpri Int
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 Int)
continued forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
streamId
    resetContinued :: IO ()
resetContinued = forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
continued forall a. Maybe a
Nothing
    checkContinued :: IO ()
checkContinued = do
        Maybe Int
mx <- forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
continued
        case Maybe Int
mx of
            Maybe Int
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Int
sid
              | Int
sid forall a. Eq a => a -> a -> Bool
== Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"continuation frame must follow"

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

processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool
processState :: StreamState -> Context -> Stream -> Int -> IO Bool
processState (Open (NoBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput :: MVar InpObj
streamInput} Int
streamId = do
    let mcl :: Maybe Int
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 (Int, ByteString)
C8.readInt)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (forall a. Eq a => a -> a -> Bool
/= (Int
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 -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
streamId
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
    IORef (Maybe (TokenHeaderList, ValueTable))
tlr <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe Int
-> IO ByteString
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl (forall a. a -> Maybe a
Just Int
0) (forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"") IORef (Maybe (TokenHeaderList, ValueTable))
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 InpObj
streamInput InpObj
inpObj
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState (Open (HasBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput} Int
streamId = do
    let mcl :: Maybe Int
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 (Int, ByteString)
C8.readInt)
    IORef Int
bodyLength <- forall a. a -> IO (IORef a)
newIORef Int
0
    IORef (Maybe (TokenHeaderList, ValueTable))
tlr <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    TQueue 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
$ OpenState -> StreamState
Open (TQueue ByteString
-> Maybe Int
-> IORef Int
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> OpenState
Body TQueue ByteString
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe (TokenHeaderList, ValueTable))
tlr)
    IORef Int
incref <- forall a. a -> IO (IORef a)
newIORef Int
0
    Source
bodySource <- TQueue ByteString -> (Int -> IO ()) -> IO Source
mkSource TQueue ByteString
q forall a b. (a -> b) -> a -> b
$ TQueue Control -> Int -> IORef Int -> Int -> IO ()
updateWindow TQueue Control
controlQ Int
streamId IORef Int
incref
    let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe Int
-> IO ByteString
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl Maybe Int
mcl (Source -> IO ByteString
readSource Source
bodySource) IORef (Maybe (TokenHeaderList, ValueTable))
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 InpObj
streamInput InpObj
inpObj
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState s :: StreamState
s@(Open Continued{}) Context
ctx Stream
strm Int
_streamId = do
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
processState StreamState
HalfClosedRemote Context
ctx Stream
strm Int
_streamId = do
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState StreamState
s Context
ctx Stream
strm Int
_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

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

getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream)
getStream :: Context -> FrameType -> Int -> IO (Maybe Stream)
getStream ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameType
ftyp Int
streamId =
    StreamTable -> Int -> IO (Maybe Stream)
search StreamTable
streamTable Int
streamId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> FrameType -> Int -> Maybe Stream -> IO (Maybe Stream)
getStream' Context
ctx FrameType
ftyp Int
streamId

getStream' :: Context -> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getStream' :: Context -> FrameType -> Int -> Maybe Stream -> IO (Maybe Stream)
getStream' Context
ctx FrameType
ftyp Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
StreamClosed Int
streamId ReasonPhrase
"header must not be sent to half or fully closed stream"
        -- Priority made an idle stream
        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
getStream' ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameType
ftyp Int
streamId Maybe Stream
Nothing
  | Int -> Bool
isServerInitiated Int
streamId = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  | Context -> Bool
isServer Context
ctx = do
        Int
csid <- Context -> IO Int
getPeerStreamID Context
ctx
        if Int
streamId forall a. Ord a => a -> a -> Bool
<= Int
csid then -- consider the stream closed
          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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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` (String -> ByteString
C8.pack (forall a. Show a => a -> String
show FrameType
ftyp)))
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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
$ do
                Context -> Int -> IO ()
setPeerStreamID Context
ctx Int
streamId
                Int
cnt <- forall a. IORef a -> IO a
readIORef IORef Int
concurrency
                -- Checking the limitation of concurrency
                -- My SETTINGS_MAX_CONCURRENT_STREAMS
                Maybe Int
mMaxConc <- Settings -> Maybe Int
maxConcurrentStreams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
mySettings
                case Maybe Int
mMaxConc of
                  Maybe Int
Nothing      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just Int
maxConc ->  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt forall a. Ord a => a -> a -> Bool
>= Int
maxConc) 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 -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
RefusedStream Int
streamId
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> FrameType -> IO Stream
openStream Context
ctx Int
streamId FrameType
ftyp
  | Bool
otherwise = forall a. HasCallStack => a
undefined -- never reach

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

type Payload = ByteString

control :: FrameType -> FrameHeader -> Payload -> Context -> Config -> IO ()
control :: FrameType
-> FrameHeader -> ByteString -> Context -> Config -> IO ()
control FrameType
FrameSettings header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context{IORef Bool
myFirstSettings :: IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings,IORef (Maybe SettingsList)
myPendingAlist :: IORef (Maybe SettingsList)
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myPendingAlist,IORef Settings
mySettings :: IORef Settings
mySettings :: Context -> IORef Settings
mySettings,TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ,Rate
settingsRate :: Rate
settingsRate :: Context -> Rate
settingsRate} Config
conf = 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError Int
streamId ReasonPhrase
"ack settings has a body"
        Maybe SettingsList
mAlist <- forall a. IORef a -> IO a
readIORef IORef (Maybe SettingsList)
myPendingAlist
        case Maybe SettingsList
mAlist of
          Maybe SettingsList
Nothing      -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- fixme
          Just SettingsList
myAlist -> do
              forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
mySettings forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
myAlist
              forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe SettingsList)
myPendingAlist forall a. Maybe a
Nothing
      else do
        -- Settings Flood - CVE-2019-9515
        Int
rate <- Rate -> IO Int
getRate Rate
settingsRate
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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
            forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
myFirstSettings Bool
True
            let myAlist :: SettingsList
myAlist = Config -> SettingsList
myInitialAlist Config
conf
            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe SettingsList)
myPendingAlist forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just SettingsList
myAlist
            let frames :: [ByteString]
frames = SettingsList -> [ByteString]
initialFrames SettingsList
myAlist forall a. [a] -> [a] -> [a]
++ [ByteString
ack]
                setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (forall a. a -> Maybe a
Just SettingsList
peerAlist) [ByteString]
frames
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe

control FrameType
FramePing FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ,Rate
pingRate :: Rate
pingRate :: Context -> Rate
pingRate} Config
_ =
    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
        Int
rate <- Rate -> IO Int
getRate Rate
pingRate
        if Int
rate forall a. Ord a => a -> a -> Bool
> Int
pingRateLimit then
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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
_ Config
_ = do
    GoAwayFrame Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsReceived ErrorCode
err Int
sid forall a b. (a -> b) -> a -> b
$ ByteString -> ReasonPhrase
Short.toShort ByteString
msg

control FrameType
FrameWindowUpdate header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context{TVar Int
txConnectionWindow :: TVar Int
txConnectionWindow :: Context -> TVar Int
txConnectionWindow} Config
_ = do
    WindowUpdateFrame Int
n <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Int
w <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      Int
w0 <- forall a. TVar a -> STM a
readTVar TVar Int
txConnectionWindow
      let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
n
      forall a. TVar a -> a -> STM ()
writeTVar TVar Int
txConnectionWindow Int
w1
      forall (m :: * -> *) a. Monad m => a -> m a
return Int
w1
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FlowControlError Int
streamId ReasonPhrase
"control window should be less than 2^31"

control FrameType
_ FrameHeader
_ ByteString
_ Context
_ Config
_ =
    -- must not reach here
    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 Int
sid ReasonPhrase
msg) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec Int
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 -> Int -> IO ()
checkPriority Priority
p Int
me
  | Int
dep forall a. Eq a => a -> a -> Bool
== Int
me = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
me
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    dep :: Int
dep = Priority -> Int
streamDependency Priority
p

stream :: FrameType -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState
stream :: FrameType
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
ctx s :: StreamState
s@(Open OpenState
JustOpened) Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
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
        Int
rate <- Rate -> IO Int
getRate forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
        if Int
rate forall a. Ord a => a -> a -> Bool
> Int
emptyFrameRateLimit then
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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 -> Int -> IO ()
checkPriority Priority
p Int
streamNumber
        if Bool
endOfHeader then do
            (TokenHeaderList, ValueTable)
tbl <- ByteString -> Int -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
frag Int
streamId Context
ctx
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
endOfStream then
                        OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
NoBody (TokenHeaderList, ValueTable)
tbl)
                       else
                        OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
HasBody (TokenHeaderList, ValueTable)
tbl)
          else do
            let siz :: Int
siz = ByteString -> Int
BS.length ByteString
frag
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open forall a b. (a -> b) -> a -> b
$ [ByteString] -> Int -> Int -> Bool -> OpenState
Continued [ByteString
frag] Int
siz Int
1 Bool
endOfStream

stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
ctx (Open (Body TQueue ByteString
q Maybe Int
_ IORef Int
_ IORef (Maybe (TokenHeaderList, ValueTable))
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
        (TokenHeaderList, ValueTable)
tbl <- ByteString -> Int -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeTrailer ByteString
frag Int
streamId Context
ctx
        forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (TokenHeaderList, ValueTable))
tlr (forall a. a -> Maybe a
Just (TokenHeaderList, ValueTable)
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 ByteString
q 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"continuation in trailer is not supported"

-- ignore data-frame except for flow-control when we're done locally
stream FrameType
FrameData
       FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}
       ByteString
_bs
       Context
ctx s :: StreamState
s@(HalfClosedLocal ClosedCode
_)
       Stream
_ = do
    Context -> Int -> IO ()
rxConnectionWindowIncrement Context
ctx Int
payloadLength
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
    if Bool
endOfStream then do
        forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

stream FrameType
FrameData
       header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId}
       ByteString
bs
       ctx :: Context
ctx@Context{Rate
emptyFrameRate :: Rate
emptyFrameRate :: Context -> Rate
emptyFrameRate} s :: StreamState
s@(Open (Body TQueue ByteString
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe (TokenHeaderList, ValueTable))
_))
       Stream
_ = do
    Context -> Int -> IO ()
rxConnectionWindowIncrement Context
ctx Int
payloadLength
    DataFrame ByteString
body <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeDataFrame FrameHeader
header ByteString
bs
    Int
len0 <- forall a. IORef a -> IO a
readIORef IORef Int
bodyLength
    let len :: Int
len = Int
len0 forall a. Num a => a -> a -> a
+ Int
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
            Int
rate <- Rate -> IO Int
getRate Rate
emptyFrameRate
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"too many empty data"
      else do
        forall a. IORef a -> a -> IO ()
writeIORef IORef Int
bodyLength Int
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 ByteString
q ByteString
body
    if Bool
endOfStream then do
        case Maybe Int
mcl of
            Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Int
cl -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cl forall a. Eq a => a -> a -> Bool
/= Int
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 -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
streamId
        -- 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 ByteString
q ByteString
""
        forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

stream FrameType
FrameContinuation FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
frag Context
ctx s :: StreamState
s@(Open (Continued [ByteString]
rfrags Int
siz Int
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
        Int
rate <- Rate -> IO Int
getRate forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
        if Int
rate forall a. Ord a => a -> a -> Bool
> Int
emptyFrameRateLimit then
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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' :: Int
siz' = Int
siz forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
frag
            n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
1
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
siz' forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"Header is too big"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
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'
            (TokenHeaderList, ValueTable)
tbl <- ByteString -> Int -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
hdrblk Int
streamId Context
ctx
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
endOfStream then
                        OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
NoBody (TokenHeaderList, ValueTable)
tbl)
                       else
                        OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
HasBody (TokenHeaderList, ValueTable)
tbl)
          else
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open forall a b. (a -> b) -> a -> b
$ [ByteString] -> Int -> Int -> Bool -> OpenState
Continued [ByteString]
rfrags' Int
siz' Int
n' Bool
endOfStream

stream FrameType
FrameWindowUpdate header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
_ StreamState
s Stream{TVar Int
streamWindow :: Stream -> TVar Int
streamWindow :: TVar Int
streamWindow} = do
    WindowUpdateFrame Int
n <- forall a. Either FrameDecodeError a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Int
w <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      Int
w0 <- forall a. TVar a -> STM a
readTVar TVar Int
streamWindow
      let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
n
      forall a. TVar a -> a -> STM ()
writeTVar TVar Int
streamWindow Int
w1
      forall (m :: * -> *) a. Monad m => a -> m a
return Int
w1
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) 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 -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
FlowControlError Int
streamId
    forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

stream FrameType
FrameRSTStream header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
ctx StreamState
_ Stream
strm = do
    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
    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 -> Int -> HTTP2Error
StreamErrorIsReceived ErrorCode
err Int
streamId

stream FrameType
FramePriority FrameHeader
header ByteString
bs Context
_ StreamState
s Stream{Int
streamNumber :: Int
streamNumber :: Stream -> Int
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 -> Int -> IO ()
checkPriority Priority
newpri Int
streamNumber
    forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- this ordering is important
stream FrameType
FrameContinuation FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"continue frame cannot come here"
stream FrameType
_ FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
_ Context
_ (Open Continued{}) Stream
_ = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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{Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
StreamClosed Int
streamId
stream FrameType
_ FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> Int -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
streamId

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

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

mkSource :: TQueue ByteString -> (Int -> IO ()) -> IO Source
mkSource :: TQueue ByteString -> (Int -> IO ()) -> IO Source
mkSource TQueue ByteString
q Int -> IO ()
update = (Int -> IO ())
-> TQueue ByteString -> IORef ByteString -> IORef Bool -> Source
Source Int -> IO ()
update TQueue 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

updateWindow :: TQueue Control -> StreamId -> IORef Int -> Int -> IO ()
updateWindow :: TQueue Control -> Int -> IORef Int -> Int -> IO ()
updateWindow TQueue Control
_ Int
_        IORef Int
_   Int
0   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateWindow TQueue Control
controlQ Int
sid IORef Int
incref Int
len = do
    Int
w0 <- forall a. IORef a -> IO a
readIORef IORef Int
incref
    let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
len
    if Int
w1 forall a. Ord a => a -> a -> Bool
>= Int
defaultWindowSize then do -- fixme
        let frame :: ByteString
frame = Int -> Int -> ByteString
windowUpdateFrame Int
sid Int
w1
        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]
        forall a. IORef a -> a -> IO ()
writeIORef IORef Int
incref Int
0
      else
        forall a. IORef a -> a -> IO ()
writeIORef IORef Int
incref Int
w1

readSource :: Source -> IO ByteString
readSource :: Source -> IO ByteString
readSource (Source Int -> IO ()
update TQueue 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 :: Int
len = ByteString -> Int
BS.length ByteString
bs
        Int -> IO ()
update Int
len
        forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
  where
    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
            ByteString
bs <- 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 ByteString
q
            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

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

rxConnectionWindowIncrement :: Context -> Int -> IO ()
rxConnectionWindowIncrement :: Context -> Int -> IO ()
rxConnectionWindowIncrement Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef (Maybe SettingsList)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxConnectionInc :: IORef Int
txConnectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
peerSettings :: IORef Settings
mySettings :: IORef Settings
myPendingAlist :: IORef (Maybe SettingsList)
myFirstSettings :: IORef Bool
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxConnectionInc :: Context -> IORef Int
txConnectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
peerSettings :: Context -> IORef Settings
mySettings :: Context -> IORef Settings
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myFirstSettings :: Context -> IORef Bool
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Int
len = do
    Int
w0 <- forall a. IORef a -> IO a
readIORef IORef Int
rxConnectionInc
    let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
len
    if Int
w1 forall a. Ord a => a -> a -> Bool
>= Int
defaultWindowSize then do -- fixme
        let frame :: ByteString
frame = Int -> Int -> ByteString
windowUpdateFrame Int
0 Int
w1
        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]
        forall a. IORef a -> a -> IO ()
writeIORef IORef Int
rxConnectionInc Int
0
      else
        forall a. IORef a -> a -> IO ()
writeIORef IORef Int
rxConnectionInc Int
w1