{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.Arch.Receiver (
frameReceiver
, maxConcurrency
, initialFrame
) where
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.IORef
import Imports hiding (delete, insert)
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP2.Arch.Context
import Network.HTTP2.Arch.EncodeFrame
import Network.HTTP2.Arch.HPACK
import Network.HTTP2.Arch.Queue
import Network.HTTP2.Arch.Rate
import Network.HTTP2.Arch.Stream
import Network.HTTP2.Arch.Types
import Network.HTTP2.Frame
maxConcurrency :: Int
maxConcurrency :: Int
maxConcurrency = Int
recommendedConcurrency
continuationLimit :: Int
continuationLimit :: Int
continuationLimit = Int
10
headerFragmentLimit :: Int
= Int
51200
pingRateLimit :: Int
pingRateLimit :: Int
pingRateLimit = Int
4
settingsRateLimit :: Int
settingsRateLimit :: Int
settingsRateLimit = Int
4
emptyFrameRateLimit :: Int
emptyFrameRateLimit :: Int
emptyFrameRateLimit = Int
4
initialFrame :: ByteString
initialFrame :: ByteString
initialFrame = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame forall a. a -> a
id [(SettingsKeyId
SettingsMaxConcurrentStreams,Int
maxConcurrency)]
type RecvN = Int -> IO ByteString
frameReceiver :: Context -> RecvN -> IO ()
frameReceiver :: Context -> RecvN -> IO ()
frameReceiver ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
..} RecvN
recvN = Int -> IO ()
loop Int
0 forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
sendGoaway
where
loop :: Int -> IO ()
loop :: Int -> IO ()
loop Int
n
| Int
n forall a. Eq a => a -> a -> Bool
== Int
6 = do
IO ()
yield
Int -> IO ()
loop Int
0
| Bool
otherwise = do
ByteString
hd <- RecvN
recvN Int
frameHeaderLength
if ByteString -> Bool
BS.null ByteString
hd then
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
else do
Bool
cont <- Context -> RecvN -> (FrameTypeId, FrameHeader) -> IO Bool
processFrame Context
ctx RecvN
recvN forall a b. (a -> b) -> a -> b
$ ByteString -> (FrameTypeId, FrameHeader)
decodeFrameHeader ByteString
hd
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cont forall a b. (a -> b) -> a -> b
$ Int -> IO ()
loop (Int
n forall a. Num a => a -> a -> a
+ Int
1)
sendGoaway :: SomeException -> IO ()
sendGoaway SomeException
e
| Just (ConnectionError ErrorCodeId
err ByteString
msg) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = do
Int
psid <- Context -> IO Int
getPeerStreamID Context
ctx
let frame :: ByteString
frame = Int -> ErrorCodeId -> ByteString -> ByteString
goawayFrame Int
psid ErrorCodeId
err ByteString
msg
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CGoaway ByteString
frame
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
processFrame :: Context -> RecvN -> (FrameTypeId, FrameHeader) -> IO Bool
processFrame :: Context -> RecvN -> (FrameTypeId, FrameHeader) -> IO Bool
processFrame Context
ctx RecvN
_recvN (FrameTypeId
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
&&
(FrameTypeId
fid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameTypeId
FramePriority,FrameTypeId
FrameRSTStream,FrameTypeId
FrameWindowUpdate]) =
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"stream id should be odd"
processFrame Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN (FrameUnknown FrameFlags
_, FrameHeader{Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength}) = do
Maybe Int
mx <- forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
continued
case Maybe Int
mx of
Maybe Int
Nothing -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ RecvN
recvN Int
payloadLength
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just Int
_ -> forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"unknown frame"
processFrame Context
ctx RecvN
recvN (FrameTypeId
FramePushPromise, header :: FrameHeader
header@FrameHeader{Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength})
| Context -> Bool
isServer Context
ctx = forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"push promise is not allowed"
| Bool
otherwise = do
ByteString
pl <- RecvN
recvN Int
payloadLength
PushPromiseFrame Int
sid ByteString
frag <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePushPromiseFrame FrameHeader
header ByteString
pl
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
isServerInitiated Int
sid) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"wrong sid for push promise"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
frag forall a. Eq a => a -> a -> Bool
== ByteString
"") forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"wrong header fragment for push promise"
(TokenHeaderList
_,ValueTable
vt) <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
frag Context
ctx
let ClientInfo{ByteString
IORef (Cache (ByteString, ByteString) Stream)
cache :: RoleInfo -> IORef (Cache (ByteString, ByteString) Stream)
authority :: RoleInfo -> ByteString
scheme :: RoleInfo -> ByteString
cache :: IORef (Cache (ByteString, ByteString) Stream)
authority :: ByteString
scheme :: ByteString
..} = Context -> RoleInfo
roleInfo Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenAuthority ValueTable
vt forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
authority
Bool -> Bool -> Bool
&& Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenScheme ValueTable
vt forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
scheme) forall a b. (a -> b) -> a -> b
$ do
let mmethod :: Maybe ByteString
mmethod = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenMethod ValueTable
vt
mpath :: Maybe ByteString
mpath = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenPath ValueTable
vt
case (Maybe ByteString
mmethod, Maybe ByteString
mpath) of
(Just ByteString
method, Just ByteString
path) -> do
Stream
strm <- Context -> Int -> FrameTypeId -> IO Stream
openStream Context
ctx Int
sid FrameTypeId
FramePushPromise
ByteString -> ByteString -> Stream -> RoleInfo -> IO ()
insertCache ByteString
method ByteString
path Stream
strm forall a b. (a -> b) -> a -> b
$ Context -> RoleInfo
roleInfo Context
ctx
(Maybe ByteString, Maybe ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
processFrame ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN typhdr :: (FrameTypeId, FrameHeader)
typhdr@(FrameTypeId
ftyp, header :: FrameHeader
header@FrameHeader{Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}) = do
Settings
settings <- forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
case Settings
-> (FrameTypeId, FrameHeader)
-> Either HTTP2Error (FrameTypeId, FrameHeader)
checkFrameHeader Settings
settings (FrameTypeId, FrameHeader)
typhdr of
Left HTTP2Error
h2err -> case HTTP2Error
h2err of
StreamError ErrorCodeId
err Int
sid -> do
ErrorCodeId -> Int -> IO ()
resetStream ErrorCodeId
err Int
sid
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ RecvN
recvN Int
payloadLength
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
HTTP2Error
connErr -> forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
connErr
Right (FrameTypeId, FrameHeader)
_ -> do
Either HTTP2Error Bool
ex <- forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ Context -> RecvN -> FrameTypeId -> FrameHeader -> IO Bool
controlOrStream Context
ctx RecvN
recvN FrameTypeId
ftyp FrameHeader
header
case Either HTTP2Error Bool
ex of
Left (StreamError ErrorCodeId
err Int
sid) -> do
ErrorCodeId -> Int -> IO ()
resetStream ErrorCodeId
err Int
sid
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Left HTTP2Error
connErr -> forall a e. Exception e => e -> a
E.throw HTTP2Error
connErr
Right Bool
cont -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
cont
where
resetStream :: ErrorCodeId -> Int -> IO ()
resetStream ErrorCodeId
err Int
sid = do
let frame :: ByteString
frame = ErrorCodeId -> Int -> ByteString
resetFrame ErrorCodeId
err Int
sid
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
controlOrStream :: Context -> RecvN -> FrameTypeId -> FrameHeader -> IO Bool
controlOrStream :: Context -> RecvN -> FrameTypeId -> FrameHeader -> IO Bool
controlOrStream ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN FrameTypeId
ftyp header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId, Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}
| Int -> Bool
isControl Int
streamId = do
ByteString
pl <- RecvN
recvN Int
payloadLength
FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
control FrameTypeId
ftyp FrameHeader
header ByteString
pl Context
ctx
| Bool
otherwise = do
IO ()
checkContinued
Maybe Stream
mstrm <- Context -> FrameTypeId -> Int -> IO (Maybe Stream)
getStream Context
ctx FrameTypeId
ftyp Int
streamId
ByteString
pl <- RecvN
recvN Int
payloadLength
case Maybe Stream
mstrm of
Just Stream
strm -> do
StreamState
state0 <- Stream -> IO StreamState
readStreamState Stream
strm
StreamState
state <- FrameTypeId
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameTypeId
ftyp FrameHeader
header ByteString
pl Context
ctx StreamState
state0 Stream
strm
IO ()
resetContinued
Bool
set <- StreamState -> Context -> Stream -> Int -> IO Bool
processState StreamState
state Context
ctx Stream
strm Int
streamId
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
set IO ()
setContinued
Maybe Stream
Nothing
| FrameTypeId
ftyp forall a. Eq a => a -> a -> Bool
== FrameTypeId
FramePriority -> do
PriorityFrame Priority
newpri <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
pl
Priority -> Int -> IO ()
checkPriority Priority
newpri Int
streamId
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where
setContinued :: IO ()
setContinued = forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
continued forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
streamId
resetContinued :: IO ()
resetContinued = forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
continued forall a. Maybe a
Nothing
checkContinued :: IO ()
checkContinued = do
Maybe Int
mx <- forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
continued
case Maybe Int
mx of
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
sid
| Int
sid forall a. Eq a => a -> a -> Bool
== Int
streamId Bool -> Bool -> Bool
&& FrameTypeId
ftyp forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameContinuation -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continuation frame must follow"
processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool
processState :: StreamState -> Context -> Stream -> Int -> IO Bool
processState (Open (NoBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput :: MVar InpObj
streamInput} Int
streamId = do
let mcl :: Maybe Int
mcl = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Int, ByteString)
C8.readInt)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe Int
mcl (forall a. Eq a => a -> a -> Bool
/= (Int
0 :: Int))) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
streamId
Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
IORef (Maybe (TokenHeaderList, ValueTable))
tlr <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe Int
-> InpBody
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl (forall a. a -> Maybe a
Just Int
0) (forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"") IORef (Maybe (TokenHeaderList, ValueTable))
tlr
if Context -> Bool
isServer Context
ctx then
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue (RoleInfo -> TQueue (Input Stream)
inputQ RoleInfo
roleInfo) forall a b. (a -> b) -> a -> b
$ forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
else
forall a. MVar a -> a -> IO ()
putMVar MVar InpObj
streamInput InpObj
inpObj
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState (Open (HasBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput} Int
streamId = do
let mcl :: Maybe Int
mcl = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Int, ByteString)
C8.readInt)
IORef Int
bodyLength <- forall a. a -> IO (IORef a)
newIORef Int
0
IORef (Maybe (TokenHeaderList, ValueTable))
tlr <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
TQueue ByteString
q <- forall a. IO (TQueue a)
newTQueueIO
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (TQueue ByteString
-> Maybe Int
-> IORef Int
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> OpenState
Body TQueue ByteString
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe (TokenHeaderList, ValueTable))
tlr)
Source
bodySource <- (Int -> IO ()) -> TQueue ByteString -> IO Source
mkSource (TQueue Control -> Int -> Int -> IO ()
updateWindow TQueue Control
controlQ Int
streamId) TQueue ByteString
q
let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe Int
-> InpBody
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl Maybe Int
mcl (Source -> InpBody
readSource Source
bodySource) IORef (Maybe (TokenHeaderList, ValueTable))
tlr
if Context -> Bool
isServer Context
ctx then
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue (RoleInfo -> TQueue (Input Stream)
inputQ RoleInfo
roleInfo) forall a b. (a -> b) -> a -> b
$ forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
else
forall a. MVar a -> a -> IO ()
putMVar MVar InpObj
streamInput InpObj
inpObj
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState s :: StreamState
s@(Open Continued{}) Context
ctx Stream
strm Int
_streamId = do
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
processState StreamState
HalfClosedRemote Context
ctx Stream
strm Int
_streamId = do
Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState StreamState
s Context
ctx Stream
strm Int
_streamId = do
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
getStream :: Context -> FrameTypeId -> StreamId -> IO (Maybe Stream)
getStream :: Context -> FrameTypeId -> Int -> IO (Maybe Stream)
getStream ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameTypeId
ftyp Int
streamId =
StreamTable -> Int -> IO (Maybe Stream)
search StreamTable
streamTable Int
streamId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> FrameTypeId -> Int -> Maybe Stream -> IO (Maybe Stream)
getStream' Context
ctx FrameTypeId
ftyp Int
streamId
getStream' :: Context -> FrameTypeId -> StreamId -> Maybe Stream -> IO (Maybe Stream)
getStream' :: Context -> FrameTypeId -> Int -> Maybe Stream -> IO (Maybe Stream)
getStream' Context
ctx FrameTypeId
ftyp Int
_streamId js :: Maybe Stream
js@(Just Stream
strm0) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameHeaders) forall a b. (a -> b) -> a -> b
$ do
StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm0
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isHalfClosedRemote StreamState
st) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
StreamClosed ByteString
"header must not be sent to half or fully closed stream"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isIdle StreamState
st) forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
strm0
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getStream' ctx :: Context
ctx@Context{IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
DynamicTable
TVar Int
TQueue Control
TQueue (Output Stream)
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameTypeId
ftyp Int
streamId Maybe Stream
Nothing
| Int -> Bool
isServerInitiated Int
streamId = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Context -> Bool
isServer Context
ctx = do
Int
csid <- Context -> IO Int
getPeerStreamID Context
ctx
if Int
streamId forall a. Ord a => a -> a -> Bool
<= Int
csid then
if FrameTypeId
ftyp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameTypeId
FrameWindowUpdate, FrameTypeId
FrameRSTStream, FrameTypeId
FramePriority] then
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"stream identifier must not decrease"
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameTypeId
FrameHeaders,FrameTypeId
FramePriority]) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError forall a b. (a -> b) -> a -> b
$ ByteString
"this frame is not allowed in an idle stream: " ByteString -> ByteString -> ByteString
`BS.append` String -> ByteString
C8.pack (forall a. Show a => a -> String
show FrameTypeId
ftyp)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameHeaders) forall a b. (a -> b) -> a -> b
$ do
Context -> Int -> IO ()
setPeerStreamID Context
ctx Int
streamId
Int
cnt <- forall a. IORef a -> IO a
readIORef IORef Int
concurrency
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt forall a. Ord a => a -> a -> Bool
>= Int
maxConcurrency) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
RefusedStream Int
streamId
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> FrameTypeId -> IO Stream
openStream Context
ctx Int
streamId FrameTypeId
ftyp
| Bool
otherwise = forall a. HasCallStack => a
undefined
control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
control FrameTypeId
FrameSettings header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameHeader -> FrameFlags
flags :: FrameFlags
flags} ByteString
bs Context{IORef Settings
http2settings :: IORef Settings
http2settings :: Context -> IORef Settings
http2settings, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, IORef Bool
firstSettings :: IORef Bool
firstSettings :: Context -> IORef Bool
firstSettings, StreamTable
streamTable :: StreamTable
streamTable :: Context -> StreamTable
streamTable, Rate
settingsRate :: Rate
settingsRate :: Context -> Rate
settingsRate} = do
SettingsFrame SettingsList
alist <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeSettingsFrame FrameHeader
header ByteString
bs
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
alist
if FrameFlags -> Bool
testAck FrameFlags
flags then
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Int
rate <- Rate -> IO Int
getRate Rate
settingsRate
if Int
rate forall a. Ord a => a -> a -> Bool
> Int
settingsRateLimit then
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"too many settings"
else do
Int
oldws <- Settings -> Int
initialWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
http2settings forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
alist
Int
newws <- Settings -> Int
initialWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
let diff :: Int
diff = Int
newws forall a. Num a => a -> a -> a
- Int
oldws
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
diff forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> StreamTable -> IO ()
updateAllStreamWindow (forall a. Num a => a -> a -> a
+ Int
diff) StreamTable
streamTable
let frame :: ByteString
frame = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
setAck []
Bool
sent <- forall a. IORef a -> IO a
readIORef IORef Bool
firstSettings
let setframe :: Control
setframe
| Bool
sent = ByteString -> SettingsList -> Control
CSettings ByteString
frame SettingsList
alist
| Bool
otherwise = ByteString -> ByteString -> SettingsList -> Control
CSettings0 ByteString
initialFrame ByteString
frame SettingsList
alist
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sent forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
firstSettings Bool
True
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
control FrameTypeId
FramePing FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags} ByteString
bs Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ,Rate
pingRate :: Rate
pingRate :: Context -> Rate
pingRate} =
if FrameFlags -> Bool
testAck FrameFlags
flags then
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Int
rate <- Rate -> IO Int
getRate Rate
pingRate
if Int
rate forall a. Ord a => a -> a -> Bool
> Int
pingRateLimit then
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"too many ping"
else do
let frame :: ByteString
frame = ByteString -> ByteString
pingFrame ByteString
bs
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
control FrameTypeId
FrameGoAway FrameHeader
_ ByteString
_ Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} = do
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
control FrameTypeId
FrameWindowUpdate FrameHeader
header ByteString
bs Context{TVar Int
connectionWindow :: TVar Int
connectionWindow :: Context -> TVar Int
connectionWindow} = do
WindowUpdateFrame Int
n <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
Int
w <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Int
w0 <- forall a. TVar a -> STM a
readTVar TVar Int
connectionWindow
let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
n
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
connectionWindow Int
w1
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
FlowControlError ByteString
"control window should be less than 2^31"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
control FrameTypeId
_ FrameHeader
_ ByteString
_ Context
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
{-# INLINE guardIt #-}
guardIt :: Either HTTP2Error a -> IO a
guardIt :: forall a. Either HTTP2Error a -> IO a
guardIt Either HTTP2Error a
x = case Either HTTP2Error a
x of
Left HTTP2Error
err -> forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
err
Right a
frame -> forall (m :: * -> *) a. Monad m => a -> m a
return a
frame
{-# INLINE checkPriority #-}
checkPriority :: Priority -> StreamId -> IO ()
checkPriority :: Priority -> Int -> IO ()
checkPriority Priority
p Int
me
| Int
dep forall a. Eq a => a -> a -> Bool
== Int
me = forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
me
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
dep :: Int
dep = Priority -> Int
streamDependency Priority
p
stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState
stream :: FrameTypeId
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameTypeId
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags} ByteString
bs Context
ctx s :: StreamState
s@(Open OpenState
JustOpened) Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber} = do
HeadersFrame Maybe Priority
mp ByteString
frag <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
endOfHeader :: Bool
endOfHeader = FrameFlags -> Bool
testEndHeader FrameFlags
flags
if ByteString
frag forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfStream Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfHeader then do
Int
rate <- Rate -> IO Int
getRate forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
if Int
rate forall a. Ord a => a -> a -> Bool
> Int
emptyFrameRateLimit then
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"too many empty headers"
else
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
else do
case Maybe Priority
mp of
Maybe Priority
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Priority
p -> Priority -> Int -> IO ()
checkPriority Priority
p Int
streamNumber
if Bool
endOfHeader then do
(TokenHeaderList, ValueTable)
tbl <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
frag Context
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
endOfStream then
OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
NoBody (TokenHeaderList, ValueTable)
tbl)
else
OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
HasBody (TokenHeaderList, ValueTable)
tbl)
else do
let siz :: Int
siz = ByteString -> Int
BS.length ByteString
frag
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open forall a b. (a -> b) -> a -> b
$ [ByteString] -> Int -> Int -> Bool -> OpenState
Continued [ByteString
frag] Int
siz Int
1 Bool
endOfStream
stream FrameTypeId
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags} ByteString
bs Context
ctx (Open (Body TQueue ByteString
q Maybe Int
_ IORef Int
_ IORef (Maybe (TokenHeaderList, ValueTable))
tlr)) Stream
_ = do
HeadersFrame Maybe Priority
_ ByteString
frag <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
if Bool
endOfStream then do
(TokenHeaderList, ValueTable)
tbl <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeTrailer ByteString
frag Context
ctx
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (TokenHeaderList, ValueTable))
tlr (forall a. a -> Maybe a
Just (TokenHeaderList, ValueTable)
tbl)
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
else
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continuation in trailer is not supported"
stream FrameTypeId
FrameData
FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}
ByteString
_bs
Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} s :: StreamState
s@(HalfClosedLocal ClosedCode
_)
Stream
_ = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
payloadLength forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ do
let frame :: ByteString
frame = Int -> Int -> ByteString
windowUpdateFrame Int
0 Int
payloadLength
TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
if Bool
endOfStream then do
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
else
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
stream FrameTypeId
FrameData
header :: FrameHeader
header@FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags,Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength,Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId}
ByteString
bs
Context{Rate
emptyFrameRate :: Rate
emptyFrameRate :: Context -> Rate
emptyFrameRate} s :: StreamState
s@(Open (Body TQueue ByteString
q Maybe Int
mcl IORef Int
bodyLength IORef (Maybe (TokenHeaderList, ValueTable))
_))
Stream
_ = do
DataFrame ByteString
body <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeDataFrame FrameHeader
header ByteString
bs
Int
len0 <- forall a. IORef a -> IO a
readIORef IORef Int
bodyLength
let len :: Int
len = Int
len0 forall a. Num a => a -> a -> a
+ Int
payloadLength
endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
if ByteString
body forall a. Eq a => a -> a -> Bool
== ByteString
"" then
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
endOfStream forall a b. (a -> b) -> a -> b
$ do
Int
rate <- Rate -> IO Int
getRate Rate
emptyFrameRate
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rate forall a. Ord a => a -> a -> Bool
> Int
emptyFrameRateLimit) forall a b. (a -> b) -> a -> b
$ do
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"too many empty data"
else do
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
bodyLength Int
len
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
body
if Bool
endOfStream then do
case Maybe Int
mcl of
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
cl -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cl forall a. Eq a => a -> a -> Bool
/= Int
len) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
streamId
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
else
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
stream FrameTypeId
FrameContinuation FrameHeader{FrameFlags
flags :: FrameFlags
flags :: FrameHeader -> FrameFlags
flags} ByteString
frag Context
ctx s :: StreamState
s@(Open (Continued [ByteString]
rfrags Int
siz Int
n Bool
endOfStream)) Stream
_ = do
let endOfHeader :: Bool
endOfHeader = FrameFlags -> Bool
testEndHeader FrameFlags
flags
if ByteString
frag forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfHeader then do
Int
rate <- Rate -> IO Int
getRate forall a b. (a -> b) -> a -> b
$ Context -> Rate
emptyFrameRate Context
ctx
if Int
rate forall a. Ord a => a -> a -> Bool
> Int
emptyFrameRateLimit then
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"too many empty continuation"
else
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
else do
let rfrags' :: [ByteString]
rfrags' = ByteString
frag forall a. a -> [a] -> [a]
: [ByteString]
rfrags
siz' :: Int
siz' = Int
siz forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
frag
n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
siz' forall a. Ord a => a -> a -> Bool
> Int
headerFragmentLimit) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
EnhanceYourCalm ByteString
"Header is too big"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' forall a. Ord a => a -> a -> Bool
> Int
continuationLimit) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
EnhanceYourCalm ByteString
"Header is too fragmented"
if Bool
endOfHeader then do
let hdrblk :: ByteString
hdrblk = [ByteString] -> ByteString
BS.concat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ByteString]
rfrags'
(TokenHeaderList, ValueTable)
tbl <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
hdrblk Context
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
endOfStream then
OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
NoBody (TokenHeaderList, ValueTable)
tbl)
else
OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
HasBody (TokenHeaderList, ValueTable)
tbl)
else
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open forall a b. (a -> b) -> a -> b
$ [ByteString] -> Int -> Int -> Bool -> OpenState
Continued [ByteString]
rfrags' Int
siz' Int
n' Bool
endOfStream
stream FrameTypeId
FrameWindowUpdate header :: FrameHeader
header@FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
bs Context
_ StreamState
s Stream{TVar Int
streamWindow :: Stream -> TVar Int
streamWindow :: TVar Int
streamWindow} = do
WindowUpdateFrame Int
n <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
Int
w <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Int
w0 <- forall a. TVar a -> STM a
readTVar TVar Int
streamWindow
let w1 :: Int
w1 = Int
w0 forall a. Num a => a -> a -> a
+ Int
n
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
streamWindow Int
w1
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
FlowControlError Int
streamId
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
stream FrameTypeId
FrameRSTStream FrameHeader
header ByteString
bs Context
ctx StreamState
_ Stream
strm = do
RSTStreamFrame ErrorCodeId
e <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decoderstStreamFrame FrameHeader
header ByteString
bs
let cc :: ClosedCode
cc = ErrorCodeId -> ClosedCode
Reset ErrorCodeId
e
Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ClosedCode -> StreamState
Closed ClosedCode
cc
stream FrameTypeId
FramePriority FrameHeader
header ByteString
bs Context
_ StreamState
s Stream{Int
streamNumber :: Int
streamNumber :: Stream -> Int
streamNumber} = do
PriorityFrame Priority
newpri <- forall a. Either HTTP2Error a -> IO a
guardIt forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
Priority -> Int -> IO ()
checkPriority Priority
newpri Int
streamNumber
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s
stream FrameTypeId
FrameContinuation FrameHeader
_ ByteString
_ Context
_ StreamState
_ Stream
_ = forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continue frame cannot come here"
stream FrameTypeId
_ FrameHeader
_ ByteString
_ Context
_ (Open Continued{}) Stream
_ = forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"an illegal frame follows header/continuation frames"
stream FrameTypeId
_ FrameHeader
_ ByteString
_ Context
_ st :: StreamState
st@(Closed (ResetByMe SomeException
_)) Stream
_ = forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
st
stream FrameTypeId
FrameData FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
StreamClosed Int
streamId
stream FrameTypeId
_ FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
streamId
data Source = Source (Int -> IO ())
(TQueue ByteString)
(IORef ByteString)
(IORef Bool)
mkSource :: (Int -> IO ()) -> TQueue ByteString -> IO Source
mkSource :: (Int -> IO ()) -> TQueue ByteString -> IO Source
mkSource Int -> IO ()
update TQueue ByteString
q = (Int -> IO ())
-> TQueue ByteString -> IORef ByteString -> IORef Bool -> Source
Source Int -> IO ()
update TQueue ByteString
q forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef ByteString
"" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Bool
False
updateWindow :: TQueue Control -> StreamId -> Int -> IO ()
updateWindow :: TQueue Control -> Int -> Int -> IO ()
updateWindow TQueue Control
_ Int
_ Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateWindow TQueue Control
controlQ Int
sid Int
len = TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
where
frame1 :: ByteString
frame1 = Int -> Int -> ByteString
windowUpdateFrame Int
0 Int
len
frame2 :: ByteString
frame2 = Int -> Int -> ByteString
windowUpdateFrame Int
sid Int
len
frame :: ByteString
frame = ByteString
frame1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
frame2
readSource :: Source -> IO ByteString
readSource :: Source -> InpBody
readSource (Source Int -> IO ()
update TQueue ByteString
q IORef ByteString
refBS IORef Bool
refEOF) = do
Bool
eof <- forall a. IORef a -> IO a
readIORef IORef Bool
refEOF
if Bool
eof then
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
else do
ByteString
bs <- InpBody
readBS
let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
Int -> IO ()
update Int
len
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
where
readBS :: InpBody
readBS = do
ByteString
bs0 <- forall a. IORef a -> IO a
readIORef IORef ByteString
refBS
if ByteString
bs0 forall a. Eq a => a -> a -> Bool
== ByteString
"" then do
ByteString
bs <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM a
readTQueue TQueue ByteString
q
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
bs forall a. Eq a => a -> a -> Bool
== ByteString
"") forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
else do
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
refBS ByteString
""
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs0