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

module Network.HTTP2.Arch.Receiver (
    frameReceiver
  ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Short as Short
import Data.IORef
import 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.Arch.Window
import Network.HTTP2.Frame

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

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

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

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

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

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

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

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

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

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

processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()
processFrame Context
ctx Config
_conf (FrameType
fid, FrameHeader{StreamId
streamId :: StreamId
streamId :: FrameHeader -> StreamId
streamId})
  | Context -> Bool
isServer Context
ctx Bool -> Bool -> Bool
&&
    StreamId -> Bool
isServerInitiated StreamId
streamId Bool -> Bool -> Bool
&&
    (FrameType
fid FrameType -> [FrameType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameType
FramePriority,FrameType
FrameRSTStream,FrameType
FrameWindowUpdate]) =
    HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"stream id should be odd"

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

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

processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool

-- Transition (process1)
processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool
processState (Open (NoBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef (Maybe SettingsList)
IORef Settings
DynamicTable
TVar StreamId
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
role :: Context -> Role
roleInfo :: Context -> RoleInfo
myFirstSettings :: Context -> IORef Bool
myPendingAlist :: Context -> IORef (Maybe SettingsList)
mySettings :: Context -> IORef Settings
peerSettings :: Context -> IORef Settings
streamTable :: Context -> StreamTable
concurrency :: Context -> IORef StreamId
continued :: Context -> IORef (Maybe StreamId)
myStreamId :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
outputBufferLimit :: Context -> IORef StreamId
outputQ :: Context -> TQueue (Output Stream)
outputQStreamID :: Context -> TVar StreamId
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txConnectionWindow :: Context -> TVar StreamId
rxConnectionInc :: Context -> IORef StreamId
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
role :: Role
roleInfo :: RoleInfo
myFirstSettings :: IORef Bool
myPendingAlist :: IORef (Maybe SettingsList)
mySettings :: IORef Settings
peerSettings :: IORef Settings
streamTable :: StreamTable
concurrency :: IORef StreamId
continued :: IORef (Maybe StreamId)
myStreamId :: IORef StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue (Output Stream)
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txConnectionWindow :: TVar StreamId
rxConnectionInc :: IORef StreamId
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput} StreamId
streamId = do
    let mcl :: Maybe StreamId
mcl = (StreamId, ByteString) -> StreamId
forall a b. (a, b) -> a
fst ((StreamId, ByteString) -> StreamId)
-> Maybe (StreamId, ByteString) -> Maybe StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt Maybe ByteString
-> (ByteString -> Maybe (StreamId, ByteString))
-> Maybe (StreamId, ByteString)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (StreamId, ByteString)
C8.readInt)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe StreamId -> (StreamId -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe StreamId
mcl (StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= (StreamId
0 :: Int))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"no body but content-length is not zero"
    Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
    IORef (Maybe (TokenHeaderList, ValueTable))
tlr <- Maybe (TokenHeaderList, ValueTable)
-> IO (IORef (Maybe (TokenHeaderList, ValueTable)))
forall a. a -> IO (IORef a)
newIORef Maybe (TokenHeaderList, ValueTable)
forall a. Maybe a
Nothing
    let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe StreamId
-> IO ByteString
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl (StreamId -> Maybe StreamId
forall a. a -> Maybe a
Just StreamId
0) (ByteString -> IO ByteString
forall a. a -> IO a
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
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Input Stream) -> Input Stream -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerInfo -> TQueue (Input Stream)
inputQ ServerInfo
si) (Input Stream -> STM ()) -> Input Stream -> STM ()
forall a b. (a -> b) -> a -> b
$ Stream -> InpObj -> Input Stream
forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
      else
        MVar InpObj -> InpObj -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar InpObj
streamInput InpObj
inpObj
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- Transition (process2)
processState (Open (HasBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef (Maybe SettingsList)
IORef Settings
DynamicTable
TVar StreamId
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
role :: Context -> Role
roleInfo :: Context -> RoleInfo
myFirstSettings :: Context -> IORef Bool
myPendingAlist :: Context -> IORef (Maybe SettingsList)
mySettings :: Context -> IORef Settings
peerSettings :: Context -> IORef Settings
streamTable :: Context -> StreamTable
concurrency :: Context -> IORef StreamId
continued :: Context -> IORef (Maybe StreamId)
myStreamId :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
outputBufferLimit :: Context -> IORef StreamId
outputQ :: Context -> TQueue (Output Stream)
outputQStreamID :: Context -> TVar StreamId
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txConnectionWindow :: Context -> TVar StreamId
rxConnectionInc :: Context -> IORef StreamId
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
role :: Role
roleInfo :: RoleInfo
myFirstSettings :: IORef Bool
myPendingAlist :: IORef (Maybe SettingsList)
mySettings :: IORef Settings
peerSettings :: IORef Settings
streamTable :: StreamTable
concurrency :: IORef StreamId
continued :: IORef (Maybe StreamId)
myStreamId :: IORef StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue (Output Stream)
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txConnectionWindow :: TVar StreamId
rxConnectionInc :: IORef StreamId
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput :: MVar InpObj
streamInput} StreamId
_streamId = do
    let mcl :: Maybe StreamId
mcl = (StreamId, ByteString) -> StreamId
forall a b. (a, b) -> a
fst ((StreamId, ByteString) -> StreamId)
-> Maybe (StreamId, ByteString) -> Maybe StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt Maybe ByteString
-> (ByteString -> Maybe (StreamId, ByteString))
-> Maybe (StreamId, ByteString)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (StreamId, ByteString)
C8.readInt)
    IORef StreamId
bodyLength <- StreamId -> IO (IORef StreamId)
forall a. a -> IO (IORef a)
newIORef StreamId
0
    IORef (Maybe (TokenHeaderList, ValueTable))
tlr <- Maybe (TokenHeaderList, ValueTable)
-> IO (IORef (Maybe (TokenHeaderList, ValueTable)))
forall a. a -> IO (IORef a)
newIORef Maybe (TokenHeaderList, ValueTable)
forall a. Maybe a
Nothing
    TQueue ByteString
q <- IO (TQueue ByteString)
forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm (StreamState -> IO ()) -> StreamState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (TQueue ByteString
-> Maybe StreamId
-> IORef StreamId
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> OpenState
Body TQueue ByteString
q Maybe StreamId
mcl IORef StreamId
bodyLength IORef (Maybe (TokenHeaderList, ValueTable))
tlr)
    IORef StreamId
incref <- StreamId -> IO (IORef StreamId)
forall a. a -> IO (IORef a)
newIORef StreamId
0
    Source
bodySource <- TQueue ByteString -> (StreamId -> IO ()) -> IO Source
mkSource TQueue ByteString
q ((StreamId -> IO ()) -> IO Source)
-> (StreamId -> IO ()) -> IO Source
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IORef StreamId -> StreamId -> IO ()
informWindowUpdate Context
ctx Stream
strm IORef StreamId
incref
    let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe StreamId
-> IO ByteString
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl Maybe StreamId
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
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Input Stream) -> Input Stream -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerInfo -> TQueue (Input Stream)
inputQ ServerInfo
si) (Input Stream -> STM ()) -> Input Stream -> STM ()
forall a b. (a -> b) -> a -> b
$ Stream -> InpObj -> Input Stream
forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
      else
        MVar InpObj -> InpObj -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar InpObj
streamInput InpObj
inpObj
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

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

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

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

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

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

getStream' :: Context -> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getStream' :: Context
-> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getStream' Context
ctx FrameType
ftyp StreamId
streamId js :: Maybe Stream
js@(Just Stream
strm0) = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm0
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isHalfClosedRemote StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
StreamClosed StreamId
streamId ReasonPhrase
"header must not be sent to half or fully closed stream"
        -- Priority made an idle stream
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isIdle StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
strm0
    Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getStream' ctx :: Context
ctx@Context{IORef Bool
IORef StreamId
IORef (Maybe StreamId)
IORef (Maybe SettingsList)
IORef Settings
DynamicTable
TVar StreamId
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
role :: Context -> Role
roleInfo :: Context -> RoleInfo
myFirstSettings :: Context -> IORef Bool
myPendingAlist :: Context -> IORef (Maybe SettingsList)
mySettings :: Context -> IORef Settings
peerSettings :: Context -> IORef Settings
streamTable :: Context -> StreamTable
concurrency :: Context -> IORef StreamId
continued :: Context -> IORef (Maybe StreamId)
myStreamId :: Context -> IORef StreamId
peerStreamId :: Context -> IORef StreamId
outputBufferLimit :: Context -> IORef StreamId
outputQ :: Context -> TQueue (Output Stream)
outputQStreamID :: Context -> TVar StreamId
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txConnectionWindow :: Context -> TVar StreamId
rxConnectionInc :: Context -> IORef StreamId
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
role :: Role
roleInfo :: RoleInfo
myFirstSettings :: IORef Bool
myPendingAlist :: IORef (Maybe SettingsList)
mySettings :: IORef Settings
peerSettings :: IORef Settings
streamTable :: StreamTable
concurrency :: IORef StreamId
continued :: IORef (Maybe StreamId)
myStreamId :: IORef StreamId
peerStreamId :: IORef StreamId
outputBufferLimit :: IORef StreamId
outputQ :: TQueue (Output Stream)
outputQStreamID :: TVar StreamId
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txConnectionWindow :: TVar StreamId
rxConnectionInc :: IORef StreamId
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
..} FrameType
ftyp StreamId
streamId Maybe Stream
Nothing
  | StreamId -> Bool
isServerInitiated StreamId
streamId = Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing
  | Context -> Bool
isServer Context
ctx = do
        StreamId
csid <- Context -> IO StreamId
getPeerStreamID Context
ctx
        if StreamId
streamId StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
<= StreamId
csid then -- consider the stream closed
          if FrameType
ftyp FrameType -> [FrameType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameType
FrameWindowUpdate, FrameType
FrameRSTStream, FrameType
FramePriority] then
              Maybe Stream -> IO (Maybe Stream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing -- will be ignored
            else
              HTTP2Error -> IO (Maybe Stream)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO (Maybe Stream))
-> HTTP2Error -> IO (Maybe Stream)
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"stream identifier must not decrease"
          else do -- consider the stream idle
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> [FrameType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameType
FrameHeaders,FrameType
FramePriority]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let errmsg :: ReasonPhrase
errmsg = ByteString -> ReasonPhrase
Short.toShort (ByteString
"this frame is not allowed in an idle stream: " ByteString -> ByteString -> ByteString
`BS.append` ([Char] -> ByteString
C8.pack (FrameType -> [Char]
forall a. Show a => a -> [Char]
show FrameType
ftyp)))
                HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
errmsg
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Context -> StreamId -> IO ()
setPeerStreamID Context
ctx StreamId
streamId
                StreamId
cnt <- IORef StreamId -> IO StreamId
forall a. IORef a -> IO a
readIORef IORef StreamId
concurrency
                -- Checking the limitation of concurrency
                -- My SETTINGS_MAX_CONCURRENT_STREAMS
                Maybe StreamId
mMaxConc <- Settings -> Maybe StreamId
maxConcurrentStreams (Settings -> Maybe StreamId) -> IO Settings -> IO (Maybe StreamId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
mySettings
                case Maybe StreamId
mMaxConc of
                  Maybe StreamId
Nothing      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just StreamId
maxConc -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
cnt StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
>= StreamId
maxConc) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
RefusedStream StreamId
streamId ReasonPhrase
"exceeds max concurrent"
            Stream -> Maybe Stream
forall a. a -> Maybe a
Just (Stream -> Maybe Stream) -> IO Stream -> IO (Maybe Stream)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> StreamId -> FrameType -> IO Stream
openStream Context
ctx StreamId
streamId FrameType
ftyp
  | Bool
otherwise = IO (Maybe Stream)
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 :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs ctx :: Context
ctx@Context{IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings :: IORef Bool
myFirstSettings,IORef (Maybe SettingsList)
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myPendingAlist :: IORef (Maybe SettingsList)
myPendingAlist,IORef Settings
mySettings :: Context -> IORef Settings
mySettings :: IORef Settings
mySettings,TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ,Rate
settingsRate :: Context -> Rate
settingsRate :: Rate
settingsRate} Config
conf = do
    SettingsFrame SettingsList
peerAlist <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeSettingsFrame FrameHeader
header ByteString
bs
    (HTTP2Error -> IO Any) -> Maybe HTTP2Error -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ HTTP2Error -> IO Any
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (Maybe HTTP2Error -> IO ()) -> Maybe HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
peerAlist
    if FrameFlags -> Bool
testAck FrameFlags
flags then do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SettingsList
peerAlist SettingsList -> SettingsList -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError StreamId
streamId ReasonPhrase
"ack settings has a body"
        Maybe SettingsList
mAlist <- IORef (Maybe SettingsList) -> IO (Maybe SettingsList)
forall a. IORef a -> IO a
readIORef IORef (Maybe SettingsList)
myPendingAlist
        case Maybe SettingsList
mAlist of
          Maybe SettingsList
Nothing      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- fixme
          Just SettingsList
myAlist -> do
              IORef Settings -> (Settings -> Settings) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
mySettings ((Settings -> Settings) -> IO ())
-> (Settings -> Settings) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
myAlist
              IORef (Maybe SettingsList) -> Maybe SettingsList -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe SettingsList)
myPendingAlist Maybe SettingsList
forall a. Maybe a
Nothing
      else do
        -- Settings Flood - CVE-2019-9515
        StreamId
rate <- Rate -> IO StreamId
getRate Rate
settingsRate
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
rate StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
settingsRateLimit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"too many settings"
        let ack :: ByteString
ack = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
setAck []
        Bool
sent <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
myFirstSettings
        if Bool
sent then do
            let setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (SettingsList -> Maybe SettingsList
forall a. a -> Maybe a
Just SettingsList
peerAlist) [ByteString
ack]
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
          else do
            -- Server side only
            [ByteString]
frames <- Config -> Context -> IO [ByteString]
updateMySettings Config
conf Context
ctx
            let setframe :: Control
setframe = Maybe SettingsList -> [ByteString] -> Control
CFrames (SettingsList -> Maybe SettingsList
forall a. a -> Maybe a
Just SettingsList
peerAlist) ([ByteString]
frames [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
ack])
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe

control FrameType
FramePing FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags,StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context{TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ,Rate
pingRate :: Context -> Rate
pingRate :: Rate
pingRate} Config
_ =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FrameFlags -> Bool
testAck FrameFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- Ping Flood - CVE-2019-9512
        StreamId
rate <- Rate -> IO StreamId
getRate Rate
pingRate
        if StreamId
rate StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
pingRateLimit then
            HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"too many ping"
          else do
            let frame :: ByteString
frame = ByteString -> ByteString
pingFrame ByteString
bs
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ByteString
frame]

control FrameType
FrameGoAway FrameHeader
header ByteString
bs Context
_ Config
_ = do
    GoAwayFrame StreamId
sid ErrorCode
err ByteString
msg <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeGoAwayFrame FrameHeader
header ByteString
bs
    if ErrorCode
err ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorCode
NoError then
        HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
ConnectionIsClosed
      else
        HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsReceived ErrorCode
err StreamId
sid (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$ ByteString -> ReasonPhrase
Short.toShort ByteString
msg

control FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
ctx Config
_ = do
    WindowUpdateFrame StreamId
n <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Context -> StreamId -> IO ()
increaseConnectionWindowSize Context
ctx StreamId
n

control FrameType
_ FrameHeader
_ ByteString
_ Context
_ Config
_ =
    -- must not reach here
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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


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

stream :: FrameType -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState

-- Transition (stream1)
stream :: FrameType
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags,StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx s :: StreamState
s@(Open OpenState
JustOpened) Stream{StreamId
streamNumber :: StreamId
streamNumber :: Stream -> StreamId
streamNumber} = do
    HeadersFrame Maybe Priority
mp ByteString
frag <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
        endOfHeader :: Bool
endOfHeader = FrameFlags -> Bool
testEndHeader FrameFlags
flags
    if ByteString
frag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfStream Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfHeader then do
        -- Empty Frame Flooding - CVE-2019-9518
        StreamId
rate <- Rate -> IO StreamId
getRate (Rate -> IO StreamId) -> Rate -> IO StreamId
forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
        if StreamId
rate StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
emptyFrameRateLimit then
            HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"too many empty headers"
          else
            StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
      else do
        case Maybe Priority
mp of
          Maybe Priority
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just Priority
p  -> Priority -> StreamId -> IO ()
checkPriority Priority
p StreamId
streamNumber
        if Bool
endOfHeader then do
            (TokenHeaderList, ValueTable)
tbl <- ByteString
-> StreamId -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
frag StreamId
streamId Context
ctx
            StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ 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 :: StreamId
siz = ByteString -> StreamId
BS.length ByteString
frag
            StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (OpenState -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString] -> StreamId -> StreamId -> Bool -> OpenState
Continued [ByteString
frag] StreamId
siz StreamId
1 Bool
endOfStream

-- Transition (stream2)
stream FrameType
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags,StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx (Open (Body TQueue ByteString
q Maybe StreamId
_ IORef StreamId
_ IORef (Maybe (TokenHeaderList, ValueTable))
tlr)) Stream
_ = do
    HeadersFrame Maybe Priority
_ ByteString
frag <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
    -- checking frag == "" is not necessary
    if Bool
endOfStream then do
        (TokenHeaderList, ValueTable)
tbl <- ByteString
-> StreamId -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeTrailer ByteString
frag StreamId
streamId Context
ctx
        IORef (Maybe (TokenHeaderList, ValueTable))
-> Maybe (TokenHeaderList, ValueTable) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (TokenHeaderList, ValueTable))
tlr ((TokenHeaderList, ValueTable)
-> Maybe (TokenHeaderList, ValueTable)
forall a. a -> Maybe a
Just (TokenHeaderList, ValueTable)
tbl)
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
        StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        -- we don't support continuation here.
        HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"continuation in trailer is not supported"

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

-- Transition (stream4)
stream FrameType
FrameData
       header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags,StreamId
payloadLength :: FrameHeader -> StreamId
payloadLength :: StreamId
payloadLength,StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId}
       ByteString
bs
       Context{Rate
emptyFrameRate :: Context -> Rate
emptyFrameRate :: Rate
emptyFrameRate} s :: StreamState
s@(Open (Body TQueue ByteString
q Maybe StreamId
mcl IORef StreamId
bodyLength IORef (Maybe (TokenHeaderList, ValueTable))
_))
       Stream
_ = do
    DataFrame ByteString
body <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeDataFrame FrameHeader
header ByteString
bs
    StreamId
len0 <- IORef StreamId -> IO StreamId
forall a. IORef a -> IO a
readIORef IORef StreamId
bodyLength
    let len :: StreamId
len = StreamId
len0 StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
payloadLength
        endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
    -- Empty Frame Flooding - CVE-2019-9518
    if ByteString
body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
endOfStream (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            StreamId
rate <- Rate -> IO StreamId
getRate Rate
emptyFrameRate
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
rate StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
emptyFrameRateLimit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"too many empty data"
      else do
        IORef StreamId -> StreamId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef StreamId
bodyLength StreamId
len
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
body
    if Bool
endOfStream then do
        case Maybe StreamId
mcl of
            Maybe StreamId
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just StreamId
cl -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamId
cl StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= StreamId
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"actual body length is not the same as content-length"
        -- no trailers
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
        StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

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

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

-- Transition (stream6)
stream FrameType
FrameRSTStream header :: FrameHeader
header@FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
bs Context
ctx StreamState
s Stream
strm = do
    RSTStreamFrame ErrorCode
err <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeRSTStreamFrame FrameHeader
header ByteString
bs
    let cc :: ClosedCode
cc = ErrorCode -> ClosedCode
Reset ErrorCode
err

    -- The spec mandates (section 8.1):
    --
    -- > When this is true, a server MAY request that the client abort
    -- > transmission of a request without error by sending a RST_STREAM with an
    -- > error code of NO_ERROR after sending a complete response (i.e., a frame
    -- > with the END_STREAM flag).
    --
    -- We check the first part ("after sending a complete response") by checking
    -- the current stream state.
    case (StreamState
s, ErrorCode
err) of
      (StreamState
HalfClosedRemote, ErrorCode
NoError) ->
        StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosedCode -> StreamState
Closed ClosedCode
cc)
      (StreamState, ErrorCode)
_otherwise -> do
        Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc
        HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> HTTP2Error
StreamErrorIsReceived ErrorCode
err StreamId
streamId

-- (No state transition)
stream FrameType
FramePriority FrameHeader
header ByteString
bs Context
_ StreamState
s Stream{StreamId
streamNumber :: Stream -> StreamId
streamNumber :: StreamId
streamNumber} = do
    -- ignore
    -- Resource Loop - CVE-2019-9513
    PriorityFrame Priority
newpri <- Either FrameDecodeError FramePayload -> IO FramePayload
forall a. Either FrameDecodeError a -> IO a
guardIt (Either FrameDecodeError FramePayload -> IO FramePayload)
-> Either FrameDecodeError FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
    Priority -> StreamId -> IO ()
checkPriority Priority
newpri StreamId
streamNumber
    StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- this ordering is important
stream FrameType
FrameContinuation FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"continue frame cannot come here"
stream FrameType
_ FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ (Open Continued{}) Stream
_ = HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError StreamId
streamId ReasonPhrase
"an illegal frame follows header/continuation frames"
-- Ignore frames to streams we have just reset, per section 5.1.
stream FrameType
_ FrameHeader
_ ByteString
_ Context
_ st :: StreamState
st@(Closed (ResetByMe SomeException
_)) Stream
_ = StreamState -> IO StreamState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
st
stream FrameType
FrameData FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
StreamClosed StreamId
streamId (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$ [Char] -> ReasonPhrase
forall a. IsString a => [Char] -> a
fromString ([Char]
"illegal data frame for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StreamId -> [Char]
forall a. Show a => a -> [Char]
show StreamId
streamId)
stream FrameType
_ FrameHeader{StreamId
streamId :: FrameHeader -> StreamId
streamId :: StreamId
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCode -> StreamId -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError StreamId
streamId (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$ [Char] -> ReasonPhrase
forall a. IsString a => [Char] -> a
fromString ([Char]
"illegal frame for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StreamId -> [Char]
forall a. Show a => a -> [Char]
show StreamId
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 -> (StreamId -> IO ()) -> IO Source
mkSource TQueue ByteString
q StreamId -> IO ()
inform = (StreamId -> IO ())
-> TQueue ByteString -> IORef ByteString -> IORef Bool -> Source
Source StreamId -> IO ()
inform TQueue ByteString
q (IORef ByteString -> IORef Bool -> Source)
-> IO (IORef ByteString) -> IO (IORef Bool -> Source)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
"" IO (IORef Bool -> Source) -> IO (IORef Bool) -> IO Source
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

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