{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.H2.Receiver (
frameReceiver,
) where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Short as Short
import Data.IORef
import Network.Control
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import Imports hiding (delete, insert)
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.EncodeFrame
import Network.HTTP2.H2.HPACK
import Network.HTTP2.H2.Queue
import Network.HTTP2.H2.Settings
import Network.HTTP2.H2.Stream
import Network.HTTP2.H2.StreamTable
import Network.HTTP2.H2.Types
import Network.HTTP2.H2.Window
continuationLimit :: Int
continuationLimit :: Int
continuationLimit = Int
10
headerFragmentLimit :: Int
= Int
51200
pingRateLimit :: Int
pingRateLimit :: Int
pingRateLimit = Int
4
settingsRateLimit :: Int
settingsRateLimit :: Int
settingsRateLimit = Int
4
emptyFrameRateLimit :: Int
emptyFrameRateLimit :: Int
emptyFrameRateLimit = Int
4
rstRateLimit :: Int
rstRateLimit :: Int
rstRateLimit = Int
4
frameReceiver :: Context -> Config -> IO ()
frameReceiver :: Context -> Config -> IO ()
frameReceiver ctx :: Context
ctx@Context{TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
..} conf :: Config
conf@Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
..} = Int -> IO ()
loop Int
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 :: Int -> IO ()
loop Int
n
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 = do
IO ()
forall (m :: * -> *). MonadIO m => m ()
yield
Int -> IO ()
loop Int
0
| Bool
otherwise = do
ByteString
hd <- Int -> IO ByteString
confReadN Int
frameHeaderLength
if ByteString -> Bool
BS.null ByteString
hd
then TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (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
Int -> IO ()
loop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
_ Int
_ 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 Int
sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
let frame :: ByteString
frame = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
sid ErrorCode
err (ByteString -> 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 Int
sid ReasonPhrase
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
let frame :: ByteString
frame = ErrorCode -> Int -> ByteString
resetFrame ErrorCode
err Int
sid
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (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' = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
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 Int
sid) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = do
let frame :: ByteString
frame = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
sid ErrorCode
err ByteString
"treat a stream error as a connection error"
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (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@(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{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 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"stream id should be odd"
processFrame Context
ctx Config
_conf (FrameType
FramePushPromise, FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"push promise is not allowed"
processFrame Context{TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} (FrameType
ftyp, FrameHeader{Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength, Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId})
| FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Ord a => a -> a -> Bool
> FrameType
maxFrameType = do
Maybe Int
mx <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
continued
case Maybe Int
mx of
Maybe Int
Nothing -> do
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
$ Int -> IO ByteString
confReadN Int
payloadLength
Just Int
_ -> 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
streamId ReasonPhrase
"unknown frame"
processFrame ctx :: Context
ctx@Context{TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Config
conf typhdr :: (FrameType, FrameHeader)
typhdr@(FrameType
ftyp, FrameHeader
header) = do
case (FrameType, FrameHeader)
-> Either FrameDecodeError (FrameType, FrameHeader)
checkFrameHeader (FrameType, FrameHeader)
typhdr of
Left (FrameDecodeError ErrorCode
ec Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec Int
sid ReasonPhrase
msg
Right (FrameType, FrameHeader)
_ -> do
let Settings{Int
maxFrameSize :: Settings -> Int
maxFrameSize :: Int
maxFrameSize, Bool
enablePush :: Settings -> Bool
enablePush :: Bool
enablePush} = Settings
mySettings
sid :: Int
sid = FrameHeader -> Int
streamId FrameHeader
header
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameHeader -> Int
payloadLength FrameHeader
header Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxFrameSize) (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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError Int
sid ReasonPhrase
"exceeds maximum frame size"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
enablePush Bool -> Bool -> Bool
&& FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
sid ReasonPhrase
"push not enabled"
Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream Context
ctx Config
conf FrameType
ftyp FrameHeader
header
controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()
controlOrStream ctx :: Context
ctx@Context{TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} FrameType
ftyp header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId, Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}
| Int -> Bool
isControl Int
streamId = do
ByteString
bs <- Int -> IO ByteString
confReadN Int
payloadLength
FrameType -> FrameHeader -> ByteString -> Context -> IO ()
control FrameType
ftyp FrameHeader
header ByteString
bs Context
ctx
| FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FramePushPromise = do
ByteString
bs <- Int -> IO ByteString
confReadN Int
payloadLength
FrameHeader -> ByteString -> Context -> IO ()
push FrameHeader
header ByteString
bs Context
ctx
| Bool
otherwise = do
IO ()
checkContinued
Maybe Stream
mstrm <- Context -> FrameType -> Int -> IO (Maybe Stream)
getStream Context
ctx FrameType
ftyp Int
streamId
ByteString
bs <- Int -> IO ByteString
confReadN Int
payloadLength
case Maybe Stream
mstrm of
Just Stream
strm -> do
StreamState
state0 <- Stream -> IO StreamState
readStreamState Stream
strm
StreamState
state <- FrameType
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameType
ftyp FrameHeader
header ByteString
bs 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
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
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 -> Int -> IO ()
checkPriority Priority
newpri Int
streamId
| Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
setContinued :: IO ()
setContinued = IORef (Maybe Int) -> Maybe Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
continued (Maybe Int -> IO ()) -> Maybe Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
streamId
resetContinued :: IO ()
resetContinued = IORef (Maybe Int) -> Maybe Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
continued Maybe Int
forall a. Maybe a
Nothing
checkContinued :: IO ()
checkContinued = do
Maybe Int
mx <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
continued
case Maybe Int
mx of
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
sid
| Int
sid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
streamId Bool -> Bool -> Bool
&& FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameContinuation -> () -> IO ()
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 -> 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 Maybe ClosedCode
_ (NoBody tbl :: HeaderTable
tbl@(TokenHeaderList
_, ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput} Int
streamId = do
let mcl :: Maybe Int
mcl = (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
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 (Int, ByteString))
-> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Int, ByteString)
C8.readInt)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> (Int -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
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 -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"no body but content-length is not zero"
IORef (Maybe HeaderTable)
tlr <- Maybe HeaderTable -> IO (IORef (Maybe HeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe HeaderTable
forall a. Maybe a
Nothing
let inpObj :: InpObj
inpObj = HeaderTable
-> Maybe Int
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
tbl (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) (ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"") IORef (Maybe HeaderTable)
tlr
if Context -> Bool
isServer Context
ctx
then do
let si :: ServerInfo
si = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
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 (Either SomeException InpObj)
-> Either SomeException InpObj -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (Either SomeException InpObj)
streamInput (Either SomeException InpObj -> IO ())
-> Either SomeException InpObj -> IO ()
forall a b. (a -> b) -> a -> b
$ InpObj -> Either SomeException InpObj
forall a b. b -> Either a b
Right InpObj
inpObj
Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState (Open Maybe ClosedCode
hcl (HasBody tbl :: HeaderTable
tbl@(TokenHeaderList
_, ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar (Either SomeException InpObj)
streamInput :: MVar (Either SomeException InpObj)
streamInput :: Stream -> MVar (Either SomeException InpObj)
streamInput} Int
_streamId = do
let mcl :: Maybe Int
mcl = (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
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 (Int, ByteString))
-> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Int, ByteString)
C8.readInt)
IORef Int
bodyLength <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IORef (Maybe HeaderTable)
tlr <- Maybe HeaderTable -> IO (IORef (Maybe HeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe HeaderTable
forall a. Maybe a
Nothing
TQueue (Either SomeException ByteString)
q <- IO (TQueue (Either SomeException 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
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (TQueue (Either SomeException ByteString)
-> Maybe Int -> IORef Int -> IORef (Maybe HeaderTable) -> OpenState
Body TQueue (Either SomeException ByteString)
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe HeaderTable)
tlr)
Source
bodySource <- TQueue (Either SomeException ByteString)
-> (Int -> IO ()) -> IO Source
mkSource TQueue (Either SomeException ByteString)
q ((Int -> IO ()) -> IO Source) -> (Int -> IO ()) -> IO Source
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> Int -> IO ()
informWindowUpdate Context
ctx Stream
strm
let inpObj :: InpObj
inpObj = HeaderTable
-> Maybe Int
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
tbl Maybe Int
mcl (Source -> IO ByteString
readSource Source
bodySource) IORef (Maybe HeaderTable)
tlr
if Context -> Bool
isServer Context
ctx
then do
let si :: ServerInfo
si = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
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 (Either SomeException InpObj)
-> Either SomeException InpObj -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (Either SomeException InpObj)
streamInput (Either SomeException InpObj -> IO ())
-> Either SomeException InpObj -> IO ()
forall a b. (a -> b) -> a -> b
$ InpObj -> Either SomeException InpObj
forall a b. b -> Either a b
Right InpObj
inpObj
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState s :: StreamState
s@(Open Maybe ClosedCode
_ Continued{}) Context
ctx Stream
strm Int
_streamId = do
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
Bool -> IO Bool
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
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState (Closed ClosedCode
cc) Context
ctx Stream
strm Int
_streamId = do
Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState StreamState
s Context
ctx Stream
strm Int
_streamId = do
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
Bool -> IO Bool
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
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameType
ftyp Int
streamId
| Bool
isEven = TVar EvenStreamTable -> Int -> IO (Maybe Stream)
lookupEven TVar EvenStreamTable
evenStreamTable Int
streamId IO (Maybe Stream)
-> (Maybe Stream -> IO (Maybe Stream)) -> IO (Maybe Stream)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)
getEvenStream Context
ctx FrameType
ftyp
| Bool
otherwise = TVar OddStreamTable -> Int -> IO (Maybe Stream)
lookupOdd TVar OddStreamTable
oddStreamTable Int
streamId IO (Maybe Stream)
-> (Maybe Stream -> IO (Maybe Stream)) -> IO (Maybe Stream)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> FrameType -> Int -> Maybe Stream -> IO (Maybe Stream)
getOddStream Context
ctx FrameType
ftyp Int
streamId
where
isEven :: Bool
isEven = Int -> Bool
isServerInitiated Int
streamId
getEvenStream :: Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)
getEvenStream :: Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)
getEvenStream Context
ctx FrameType
ftyp js :: Maybe Stream
js@(Just Stream
strm) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameType
ftyp FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isReserved StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getEvenStream Context
_ FrameType
_ Maybe Stream
Nothing = Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing
getOddStream
:: Context -> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getOddStream :: Context -> FrameType -> Int -> Maybe Stream -> IO (Maybe Stream)
getOddStream Context
ctx FrameType
ftyp Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
StreamClosed
Int
streamId
ReasonPhrase
"header must not be sent to half or fully closed 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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getOddStream Context
ctx FrameType
ftyp Int
streamId Maybe Stream
Nothing
| Context -> Bool
isServer Context
ctx = do
Int
csid <- Context -> IO Int
getPeerStreamID Context
ctx
if Int
streamId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
csid
then
if FrameType
ftyp FrameType -> [FrameType] -> 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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"stream identifier must not decrease"
else do
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` (String -> ByteString
C8.pack (FrameType -> String
forall a. Show a => a -> String
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ProtocolError Int
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
$ Context -> Int -> IO ()
setPeerStreamID Context
ctx Int
streamId
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 -> Int -> FrameType -> IO Stream
openOddStreamCheck Context
ctx Int
streamId FrameType
ftyp
| Bool
otherwise = IO (Maybe Stream)
forall a. HasCallStack => a
undefined
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 Bool
myFirstSettings :: IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, Rate
settingsRate :: Rate
settingsRate :: Context -> Rate
settingsRate, Settings
mySettings :: Settings
mySettings :: Context -> Settings
mySettings, IORef RxFlow
rxFlow :: IORef RxFlow
rxFlow :: Context -> IORef RxFlow
rxFlow} = do
SettingsFrame SettingsList
peerAlist <- 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
FrameSizeError Int
streamId ReasonPhrase
"ack settings has a body"
else do
Int
rate <- Rate -> IO Int
getRate Rate
settingsRate
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
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
Int
connRxWS <- RxFlow -> Int
rxfWindow (RxFlow -> Int) -> IO RxFlow -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef RxFlow -> IO RxFlow
forall a. IORef a -> IO a
readIORef IORef RxFlow
rxFlow
let frames :: [ByteString]
frames = Settings -> Int -> [ByteString]
makeNegotiationFrames Settings
mySettings Int
connRxWS
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])
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
myFirstSettings Bool
True
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
control FrameType
FramePing FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags, 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} =
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
Int
rate <- Rate -> IO Int
getRate Rate
pingRate
if Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm 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 (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
_ = do
GoAwayFrame Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsReceived ErrorCode
err Int
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 = do
WindowUpdateFrame Int
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 -> Int -> IO ()
increaseConnectionWindowSize Context
ctx Int
n
control FrameType
_ FrameHeader
_ ByteString
_ Context
_ =
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
push :: FrameHeader -> ByteString -> Context -> IO ()
push :: FrameHeader -> ByteString -> Context -> IO ()
push header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
ctx = do
PushPromiseFrame Int
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
bs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
isServerInitiated Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"push promise must specify an even stream identifier"
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"wrong header fragment for push promise"
(TokenHeaderList
_, ValueTable
vt) <- ByteString -> Int -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
frag Int
streamId Context
ctx
let ClientInfo{ByteString
authority :: ClientInfo -> ByteString
scheme :: ClientInfo -> ByteString
authority :: ByteString
scheme :: ByteString
..} = 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) ->
Context -> Int -> ByteString -> ByteString -> IO ()
openEvenStreamCacheCheck Context
ctx Int
sid ByteString
method ByteString
path
(Maybe ByteString, Maybe ByteString)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE guardIt #-}
guardIt :: Either FrameDecodeError a -> IO a
guardIt :: Either FrameDecodeError a -> IO a
guardIt Either FrameDecodeError a
x = case Either FrameDecodeError a
x of
Left (FrameDecodeError ErrorCode
ec Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
ec Int
sid ReasonPhrase
msg
Right a
frame -> a -> IO a
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
me ReasonPhrase
"priority depends on itself"
| Bool
otherwise = () -> IO ()
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 Maybe ClosedCode
hcl OpenState
JustOpened) Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
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
Int
rate <- Rate -> IO Int
getRate (Rate -> IO Int) -> Rate -> IO Int
forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
if Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many empty headers"
else StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
else do
case Maybe Priority
mp of
Maybe Priority
Nothing -> () -> IO ()
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
HeaderTable
tbl <- ByteString -> Int -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
frag Int
streamId Context
ctx
StreamState -> IO StreamState
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
Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (HeaderTable -> OpenState
NoBody HeaderTable
tbl)
else Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (HeaderTable -> OpenState
HasBody HeaderTable
tbl)
else do
let siz :: Int
siz = ByteString -> Int
BS.length ByteString
frag
StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (OpenState -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString] -> 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 Maybe ClosedCode
_ (Body TQueue (Either SomeException ByteString)
q Maybe Int
_ IORef Int
_ IORef (Maybe HeaderTable)
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
if Bool
endOfStream
then do
HeaderTable
tbl <- ByteString -> Int -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
frag Int
streamId Context
ctx
IORef (Maybe HeaderTable) -> Maybe HeaderTable -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe HeaderTable)
tlr (HeaderTable -> Maybe HeaderTable
forall a. a -> Maybe a
Just HeaderTable
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 (Either SomeException ByteString)
-> Either SomeException ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException ByteString)
q (Either SomeException ByteString -> STM ())
-> Either SomeException ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either SomeException ByteString
forall a b. b -> Either a b
Right ByteString
""
StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
else
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"continuation in trailer is not supported"
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, IORef RxFlow
rxFlow :: IORef RxFlow
rxFlow :: Context -> IORef RxFlow
rxFlow}
s :: StreamState
s@(Open Maybe ClosedCode
_ (Body TQueue (Either SomeException ByteString)
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe HeaderTable)
_))
Stream{Int
TVar TxFlow
IORef RxFlow
IORef StreamState
MVar (Either SomeException InpObj)
streamRxFlow :: Stream -> IORef RxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamState :: Stream -> IORef StreamState
streamRxFlow :: IORef RxFlow
streamTxFlow :: TVar TxFlow
streamInput :: MVar (Either SomeException InpObj)
streamState :: IORef StreamState
streamNumber :: Int
streamNumber :: Stream -> Int
streamInput :: Stream -> MVar (Either SomeException InpObj)
..} = 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
Bool
okc <- IORef RxFlow -> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef RxFlow
rxFlow ((RxFlow -> (RxFlow, Bool)) -> IO Bool)
-> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> RxFlow -> (RxFlow, Bool)
checkRxLimit Int
payloadLength
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
okc (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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
EnhanceYourCalm
Int
streamId
ReasonPhrase
"exceeds connection flow-control limit"
Bool
oks <- IORef RxFlow -> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef RxFlow
streamRxFlow ((RxFlow -> (RxFlow, Bool)) -> IO Bool)
-> (RxFlow -> (RxFlow, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> RxFlow -> (RxFlow, Bool)
checkRxLimit Int
payloadLength
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
oks (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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
EnhanceYourCalm
Int
streamId
ReasonPhrase
"exceeds stream flow-control limit"
Int
len0 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
bodyLength
let len :: Int
len = Int
len0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
payloadLength
endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
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
Int
rate <- Rate -> IO Int
getRate Rate
emptyFrameRate
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many empty data"
else do
IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
bodyLength Int
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 (Either SomeException ByteString)
-> Either SomeException ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException ByteString)
q (Either SomeException ByteString -> STM ())
-> Either SomeException ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either SomeException ByteString
forall a b. b -> Either a b
Right ByteString
body
if Bool
endOfStream
then do
case Maybe Int
mcl of
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
cl ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
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 -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"actual body length is not the same as content-length"
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException ByteString)
-> Either SomeException ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Either SomeException ByteString)
q (Either SomeException ByteString -> STM ())
-> Either SomeException ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Either SomeException ByteString
forall a b. b -> Either a b
Right ByteString
""
StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
else StreamState -> IO StreamState
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 Maybe ClosedCode
hcl (Continued [ByteString]
rfrags Int
siz Int
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
Int
rate <- Rate -> IO Int
getRate (Rate -> IO Int) -> Rate -> IO Int
forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
if Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many empty continuation"
else StreamState -> IO StreamState
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' :: Int
siz' = Int
siz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
frag
n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
siz' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"Header is too big"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> 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 ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
rfrags'
HeaderTable
tbl <- ByteString -> Int -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
hdrblk Int
streamId Context
ctx
StreamState -> IO StreamState
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
Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (HeaderTable -> OpenState
NoBody HeaderTable
tbl)
else Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (HeaderTable -> OpenState
HasBody HeaderTable
tbl)
else StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ Maybe ClosedCode -> OpenState -> StreamState
Open Maybe ClosedCode
hcl (OpenState -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Int -> Int -> Bool -> OpenState
Continued [ByteString]
rfrags' Int
siz' Int
n' Bool
endOfStream
stream FrameType
FrameWindowUpdate FrameHeader
header ByteString
bs Context
_ StreamState
s Stream
strm = do
WindowUpdateFrame Int
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 -> Int -> IO ()
increaseStreamWindowSize Stream
strm Int
n
StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
stream FrameType
FrameRSTStream header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
ctx StreamState
s Stream
strm = do
Int
rate <- Rate -> IO Int
getRate (Rate -> IO Int) -> Rate -> IO Int
forall a b. (a -> b) -> a -> b
$ Context -> Rate
rstRate Context
ctx
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
rstRateLimit) (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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
EnhanceYourCalm Int
streamId ReasonPhrase
"too many rst_stream"
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
case (StreamState
s, ErrorCode
err) of
(StreamState
HalfClosedRemote, ErrorCode
NoError) ->
StreamState -> IO StreamState
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 -> 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
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 -> Int -> IO ()
checkPriority Priority
newpri Int
streamNumber
StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
stream FrameType
FrameContinuation FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> 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 Maybe ClosedCode
_ 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 -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
ErrorCode
ProtocolError
Int
streamId
ReasonPhrase
"an illegal frame follows header/continuation frames"
stream FrameType
_ FrameHeader
_ ByteString
_ Context
_ st :: StreamState
st@(Closed (ResetByMe SomeException
_)) Stream
_ = StreamState -> IO StreamState
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
_ =
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 -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
StreamClosed Int
streamId (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$
String -> ReasonPhrase
forall a. IsString a => String -> a
fromString (String
"illegal data frame for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
streamId)
stream FrameType
x FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
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 -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError Int
streamId (ReasonPhrase -> HTTP2Error) -> ReasonPhrase -> HTTP2Error
forall a b. (a -> b) -> a -> b
$
String -> ReasonPhrase
forall a. IsString a => String -> a
fromString (String
"illegal frame " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FrameType -> String
forall a. Show a => a -> String
show FrameType
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
streamId)
data Source
= Source
(Int -> IO ())
(TQueue (Either E.SomeException ByteString))
(IORef ByteString)
(IORef Bool)
mkSource
:: TQueue (Either E.SomeException ByteString) -> (Int -> IO ()) -> IO Source
mkSource :: TQueue (Either SomeException ByteString)
-> (Int -> IO ()) -> IO Source
mkSource TQueue (Either SomeException ByteString)
q Int -> IO ()
inform = (Int -> IO ())
-> TQueue (Either SomeException ByteString)
-> IORef ByteString
-> IORef Bool
-> Source
Source Int -> IO ()
inform TQueue (Either SomeException 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 (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 Int -> IO ()
inform TQueue (Either SomeException 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 (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
else do
ByteString
bs <- IO ByteString
readBS
let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
Int -> IO ()
inform Int
len
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
where
readBS :: IO ByteString
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
Either SomeException ByteString
mBS <- STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString))
-> STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ TQueue (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. TQueue a -> STM a
readTQueue TQueue (Either SomeException ByteString)
q
case Either SomeException ByteString
mBS of
Left SomeException
err -> do
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
True
SomeException -> IO ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
err
Right ByteString
bs -> do
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs0