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

module Network.HTTP2.Arch.Receiver (
    frameReceiver
  , maxConcurrency
  , initialFrame
  ) 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.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

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

initialFrame :: ByteString
initialFrame :: ByteString
initialFrame = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame forall a. a -> a
id [(SettingsKey
SettingsMaxConcurrentStreams,Int
maxConcurrency)]

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

type RecvN = Int -> IO ByteString

frameReceiver :: Context -> RecvN -> IO ()
frameReceiver :: Context -> RecvN -> IO ()
frameReceiver ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
..} RecvN
recvN = 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 <- RecvN
recvN Int
frameHeaderLength
        if ByteString -> Bool
BS.null ByteString
hd then
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
          else do
            Context -> RecvN -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx RecvN
recvN 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
e
      | Just HTTP2Error
ConnectionIsClosed  <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
ConnectionIsClosed
      | Just (ConnectionErrorIsReceived ErrorCode
_ Int
_ ReasonPhrase
_) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e =
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
e
      | Just (ConnectionErrorIsSent ErrorCode
err Int
sid ReasonPhrase
msg) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = 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
$ ByteString -> Control
CGoaway ByteString
frame
      | Just (StreamErrorIsSent ErrorCode
err Int
sid) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = 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
$ ByteString -> Control
CFrame 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
$ ByteString -> Control
CGoaway ByteString
frame'
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
e
      | Just (StreamErrorIsReceived ErrorCode
err Int
sid) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = 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
$ ByteString -> Control
CGoaway ByteString
frame
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
e
      -- this never happens
      | Just x :: HTTP2Error
x@(BadThingHappen SomeException
_) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
x
      | Bool
otherwise = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ SomeException -> HTTP2Error
BadThingHappen SomeException
e

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

processFrame :: Context -> RecvN -> (FrameType, FrameHeader) -> IO ()
processFrame :: Context -> RecvN -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx RecvN
_recvN (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 Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN (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
$ RecvN
recvN 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 RecvN
recvN (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 <- RecvN
recvN 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 Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN typhdr :: (FrameType, FrameHeader)
typhdr@(FrameType
ftyp, FrameHeader
header) = do
    Settings
settings <- forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
    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 -> RecvN -> FrameType -> FrameHeader -> IO ()
controlOrStream Context
ctx RecvN
recvN FrameType
ftyp FrameHeader
header

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

controlOrStream :: Context -> RecvN -> FrameType -> FrameHeader -> IO ()
controlOrStream :: Context -> RecvN -> FrameType -> FrameHeader -> IO ()
controlOrStream ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN 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 <- RecvN
recvN Int
payloadLength
      FrameType -> FrameHeader -> ByteString -> Context -> IO ()
control FrameType
ftyp FrameHeader
header ByteString
pl Context
ctx
  | Bool
otherwise = do
      IO ()
checkContinued
      Maybe Stream
mstrm <- Context -> FrameType -> Int -> IO (Maybe Stream)
getStream Context
ctx FrameType
ftyp Int
streamId
      ByteString
pl <- RecvN
recvN 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 Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
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
-> InpBody
-> 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 Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
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)
    Source
bodySource <- (Int -> IO ()) -> TQueue ByteString -> IO Source
mkSource (TQueue Control -> Int -> Int -> IO ()
updateWindow TQueue Control
controlQ Int
streamId) TQueue ByteString
q
    let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe Int
-> InpBody
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl Maybe Int
mcl (Source -> InpBody
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 Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
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 Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
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
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt forall a. Ord a => a -> a -> Bool
>= Int
maxConcurrency) 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 -> IO ()
control :: FrameType -> FrameHeader -> ByteString -> Context -> 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 Settings
http2settings :: IORef Settings
http2settings :: Context -> IORef Settings
http2settings, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, IORef Bool
firstSettings :: IORef Bool
firstSettings :: Context -> IORef Bool
firstSettings, StreamTable
streamTable :: StreamTable
streamTable :: Context -> StreamTable
streamTable, Rate
settingsRate :: Rate
settingsRate :: Context -> Rate
settingsRate} = do
    SettingsFrame SettingsList
alist <- 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
alist
    -- HTTP/2 Setting from a browser
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FrameFlags -> Bool
testAck FrameFlags
flags) forall a b. (a -> b) -> a -> b
$ do
        -- Settings Flood - CVE-2019-9515
        Int
rate <- Rate -> IO Int
getRate Rate
settingsRate
        if Int
rate forall a. Ord a => a -> a -> Bool
> Int
settingsRateLimit 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 settings"
          else do
            Int
oldws <- Settings -> Int
initialWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
            forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
http2settings forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
alist
            Int
newws <- Settings -> Int
initialWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
            let diff :: Int
diff = Int
newws forall a. Num a => a -> a -> a
- Int
oldws
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
diff forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> StreamTable -> IO ()
updateAllStreamWindow (forall a. Num a => a -> a -> a
+ Int
diff) StreamTable
streamTable
            let frame :: ByteString
frame = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
setAck []
            Bool
sent <- forall a. IORef a -> IO a
readIORef IORef Bool
firstSettings
            let setframe :: Control
setframe
                  | Bool
sent      = ByteString -> SettingsList -> Control
CSettings               ByteString
frame SettingsList
alist
                  | Bool
otherwise = ByteString -> ByteString -> SettingsList -> Control
CSettings0 ByteString
initialFrame ByteString
frame SettingsList
alist
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sent forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
firstSettings Bool
True
            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} =
    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
$ ByteString -> Control
CFrame ByteString
frame

control FrameType
FrameGoAway FrameHeader
header ByteString
bs Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} = do
    TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
    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
connectionWindow :: TVar Int
connectionWindow :: Context -> TVar Int
connectionWindow} = 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
connectionWindow
      let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
n
      forall a. TVar a -> a -> STM ()
writeTVar TVar Int
connectionWindow 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
_ =
    -- 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{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} s :: StreamState
s@(HalfClosedLocal ClosedCode
_)
       Stream
_ = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
payloadLength forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ do
        let frame :: ByteString
frame = Int -> Int -> ByteString
windowUpdateFrame Int
0 Int
payloadLength
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
    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
       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
    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 ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} StreamState
_ Stream
strm = do
    TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
    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 :: (Int -> IO ()) -> TQueue ByteString -> IO Source
mkSource :: (Int -> IO ()) -> TQueue ByteString -> IO Source
mkSource Int -> IO ()
update TQueue ByteString
q = (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 -> Int -> IO ()
updateWindow :: TQueue Control -> Int -> Int -> IO ()
updateWindow TQueue Control
_        Int
_   Int
0   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateWindow TQueue Control
controlQ Int
sid Int
len = TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
  where
    frame1 :: ByteString
frame1 = Int -> Int -> ByteString
windowUpdateFrame Int
0 Int
len
    frame2 :: ByteString
frame2 = Int -> Int -> ByteString
windowUpdateFrame Int
sid Int
len
    frame :: ByteString
frame = ByteString
frame1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
frame2

readSource :: Source -> IO ByteString
readSource :: Source -> InpBody
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 <- InpBody
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 :: InpBody
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