{-# 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
headerFragmentLimit :: Int
headerFragmentLimit = Int
51200 -- 50K

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

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

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

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

initialFrame :: ByteString
initialFrame :: ByteString
initialFrame = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
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{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
..} RecvN
recvN = Int -> IO ()
loop Int
0 IO () -> (SomeException -> IO ()) -> IO ()
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 Int -> Int -> Bool
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 ((FrameTypeId, FrameHeader) -> IO Bool)
-> (FrameTypeId, FrameHeader) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> (FrameTypeId, FrameHeader)
decodeFrameHeader ByteString
hd
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cont (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
loop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

    sendGoaway :: SomeException -> IO ()
sendGoaway SomeException
e
      | Just (ConnectionError ErrorCodeId
err ByteString
msg) <- SomeException -> Maybe HTTP2Error
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 (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CGoaway ByteString
frame
      | Bool
otherwise = () -> IO ()
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 FrameTypeId -> [FrameTypeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameTypeId
FramePriority,FrameTypeId
FrameRSTStream,FrameTypeId
FrameWindowUpdate]) =
    HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"stream id should be odd"
processFrame Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN (FrameUnknown FrameFlags
_, FrameHeader{Int
payloadLength :: FrameHeader -> Int
payloadLength :: Int
payloadLength}) = 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
            -- ignoring unknown frame
            IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ RecvN
recvN Int
payloadLength
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Just Int
_  -> HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
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 = HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePushPromiseFrame FrameHeader
header ByteString
pl
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
isServerInitiated Int
sid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"wrong sid for push promise"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
frag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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{IORef (Cache (ByteString, ByteString) Stream)
ByteString
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
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenAuthority ValueTable
vt Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
authority
         Bool -> Bool -> Bool
&& Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenScheme    ValueTable
vt Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
scheme) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let mmethod :: Maybe ByteString
mmethod = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenMethod ValueTable
vt
              mpath :: Maybe ByteString
mpath   = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenPath   ValueTable
vt
          case (Maybe ByteString
mmethod, Maybe ByteString
mpath) of
            (Just ByteString
method, Just ByteString
path) -> do
                Stream
strm <- Context -> Int -> FrameTypeId -> IO Stream
openStream Context
ctx Int
sid FrameTypeId
FramePushPromise
                ByteString -> ByteString -> Stream -> RoleInfo -> IO ()
insertCache ByteString
method ByteString
path Stream
strm (RoleInfo -> IO ()) -> RoleInfo -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> RoleInfo
roleInfo Context
ctx
            (Maybe ByteString, Maybe ByteString)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
processFrame ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN typhdr :: (FrameTypeId, FrameHeader)
typhdr@(FrameTypeId
ftyp, header :: FrameHeader
header@FrameHeader{Int
payloadLength :: Int
payloadLength :: FrameHeader -> Int
payloadLength}) = do
    Settings
settings <- IORef Settings -> IO 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
              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
$ RecvN
recvN Int
payloadLength
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          HTTP2Error
connErr -> HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
connErr
      Right (FrameTypeId, FrameHeader)
_ -> do
          Either HTTP2Error Bool
ex <- IO Bool -> IO (Either HTTP2Error Bool)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO Bool -> IO (Either HTTP2Error Bool))
-> IO Bool -> IO (Either HTTP2Error Bool)
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
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
              Left HTTP2Error
connErr -> HTTP2Error -> IO Bool
forall a e. Exception e => e -> a
E.throw HTTP2Error
connErr
              Right Bool
cont -> Bool -> IO Bool
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 (Control -> IO ()) -> Control -> IO ()
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{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} RecvN
recvN 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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
set IO ()
setContinued
        Maybe Stream
Nothing
          | FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FramePriority -> do
                -- for h2spec only
                PriorityFrame Priority
newpri <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
pl
                Priority -> Int -> IO ()
checkPriority Priority
newpri Int
streamId
          | Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  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
&& FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameContinuation -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise -> HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput :: MVar InpObj
streamInput} Int
streamId = do
    let mcl :: Maybe Int
mcl = (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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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 <- Maybe (TokenHeaderList, ValueTable)
-> IO (IORef (Maybe (TokenHeaderList, ValueTable)))
forall a. a -> IO (IORef a)
newIORef Maybe (TokenHeaderList, ValueTable)
forall a. Maybe a
Nothing
    let inpObj :: InpObj
inpObj = (TokenHeaderList, ValueTable)
-> Maybe Int
-> IO ByteString
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
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 (TokenHeaderList, ValueTable))
tlr
    if Context -> Bool
isServer Context
ctx then
        STM () -> IO ()
forall a. STM a -> IO 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 (RoleInfo -> TQueue (Input Stream)
inputQ RoleInfo
roleInfo) (Input Stream -> STM ()) -> Input Stream -> STM ()
forall a b. (a -> b) -> a -> b
$ Stream -> InpObj -> Input Stream
forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
      else
        MVar InpObj -> InpObj -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar InpObj
streamInput InpObj
inpObj
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
processState (Open (HasBody tbl :: (TokenHeaderList, ValueTable)
tbl@(TokenHeaderList
_,ValueTable
reqvt))) ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} strm :: Stream
strm@Stream{MVar InpObj
streamInput :: MVar InpObj
streamInput :: Stream -> MVar InpObj
streamInput} Int
streamId = do
    let mcl :: Maybe Int
mcl = (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 (TokenHeaderList, ValueTable))
tlr <- Maybe (TokenHeaderList, ValueTable)
-> IO (IORef (Maybe (TokenHeaderList, ValueTable)))
forall a. a -> IO (IORef a)
newIORef Maybe (TokenHeaderList, ValueTable)
forall a. Maybe a
Nothing
    TQueue ByteString
q <- IO (TQueue ByteString)
forall a. IO (TQueue a)
newTQueueIO
    Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm (StreamState -> IO ()) -> StreamState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (TQueue ByteString
-> Maybe 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
-> IO ByteString
-> IORef (Maybe (TokenHeaderList, ValueTable))
-> InpObj
InpObj (TokenHeaderList, ValueTable)
tbl Maybe Int
mcl (Source -> IO ByteString
readSource Source
bodySource) IORef (Maybe (TokenHeaderList, ValueTable))
tlr
    if Context -> Bool
isServer Context
ctx then
        STM () -> IO ()
forall a. STM a -> IO 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 (RoleInfo -> TQueue (Input Stream)
inputQ RoleInfo
roleInfo) (Input Stream -> STM ()) -> Input Stream -> STM ()
forall a b. (a -> b) -> a -> b
$ Stream -> InpObj -> Input Stream
forall a. a -> InpObj -> Input a
Input Stream
strm InpObj
inpObj
      else
        MVar InpObj -> InpObj -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar InpObj
streamInput InpObj
inpObj
    Bool -> IO Bool
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
    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 StreamState
s Context
ctx Stream
strm Int
_streamId = do
    -- Idle, Open Body, Closed
    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 -> FrameTypeId -> StreamId -> IO (Maybe Stream)
getStream :: Context -> FrameTypeId -> Int -> IO (Maybe Stream)
getStream ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameTypeId
ftyp Int
streamId =
    StreamTable -> Int -> IO (Maybe Stream)
search StreamTable
streamTable 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 -> 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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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"
        -- Priority made an idle stream
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isIdle StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
strm0
    Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
getStream' ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} FrameTypeId
ftyp Int
streamId Maybe Stream
Nothing
  | Int -> Bool
isServerInitiated Int
streamId = Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
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 -- consider the stream closed
          if FrameTypeId
ftyp FrameTypeId -> [FrameTypeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameTypeId
FrameWindowUpdate, FrameTypeId
FrameRSTStream, FrameTypeId
FramePriority] then
              Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing -- will be ignored
            else
              HTTP2Error -> IO (Maybe Stream)
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO (Maybe Stream))
-> HTTP2Error -> IO (Maybe Stream)
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"stream identifier must not decrease"
          else do -- consider the stream idle
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> [FrameTypeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameTypeId
FrameHeaders,FrameTypeId
FramePriority]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError (ByteString -> HTTP2Error) -> ByteString -> HTTP2Error
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 (FrameTypeId -> String
forall a. Show a => a -> String
show FrameTypeId
ftyp)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Context -> Int -> IO ()
setPeerStreamID Context
ctx Int
streamId
                Int
cnt <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
concurrency
                -- Checking the limitation of concurrency
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxConcurrency) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
RefusedStream 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 -> FrameTypeId -> IO Stream
openStream Context
ctx Int
streamId FrameTypeId
ftyp
  | Bool
otherwise = IO (Maybe Stream)
forall a. HasCallStack => a
undefined -- never reach

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

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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error 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 e a. Exception e => e -> IO a
E.throwIO (Maybe HTTP2Error -> IO ()) -> Maybe HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
alist
    -- HTTP/2 Setting from a browser
    if FrameFlags -> Bool
testAck FrameFlags
flags then
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        -- Settings Flood - CVE-2019-9515
        Int
rate <- Rate -> IO Int
getRate Rate
settingsRate
        if Int
rate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
settingsRateLimit then
            HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"too many settings"
          else do
            Int
oldws <- Settings -> Int
initialWindowSize (Settings -> Int) -> IO Settings -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
            IORef Settings -> (Settings -> Settings) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
http2settings ((Settings -> Settings) -> IO ())
-> (Settings -> Settings) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
alist
            Int
newws <- Settings -> Int
initialWindowSize (Settings -> Int) -> IO Settings -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
            let diff :: Int
diff = Int
newws Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldws
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
diff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> StreamTable -> IO ()
updateAllStreamWindow (Int -> Int -> Int
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 <- IORef Bool -> IO Bool
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sent (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
firstSettings Bool
True
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
            Bool -> IO Bool
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
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        -- Ping Flood - CVE-2019-9512
        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 Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
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 (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
            Bool -> IO Bool
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
    Bool -> IO Bool
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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Int
w <- STM Int -> IO Int
forall a. STM a -> IO a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
      Int
w0 <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
connectionWindow
      let w1 :: Int
w1 = Int
w0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
      TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
connectionWindow Int
w1
      Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w1
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
FlowControlError ByteString
"control window should be less than 2^31"
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

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

{-# INLINE guardIt #-}
guardIt :: Either HTTP2Error a -> IO a
guardIt :: Either HTTP2Error a -> IO a
guardIt Either HTTP2Error a
x = case Either HTTP2Error a
x of
    Left HTTP2Error
err    -> HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
err
    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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
me
  | Bool
otherwise = () -> IO ()
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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
        endOfHeader :: Bool
endOfHeader = FrameFlags -> Bool
testEndHeader FrameFlags
flags
    if ByteString
frag ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfStream Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfHeader then do
        -- Empty Frame Flooding - CVE-2019-9518
        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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"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
            (TokenHeaderList, ValueTable)
tbl <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
frag 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
                        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
            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
$ OpenState -> StreamState
Open (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 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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let endOfStream :: Bool
endOfStream = FrameFlags -> Bool
testEndStream FrameFlags
flags
    -- checking frag == "" is not necessary
    if Bool
endOfStream then do
        (TokenHeaderList, ValueTable)
tbl <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeTrailer ByteString
frag Context
ctx
        IORef (Maybe (TokenHeaderList, ValueTable))
-> Maybe (TokenHeaderList, ValueTable) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (TokenHeaderList, ValueTable))
tlr ((TokenHeaderList, ValueTable)
-> Maybe (TokenHeaderList, ValueTable)
forall a. a -> Maybe a
Just (TokenHeaderList, ValueTable)
tbl)
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        -- we don't support continuation here.
        HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continuation in trailer is not supported"

-- ignore data-frame except for flow-control when we're done locally
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
payloadLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
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 (Control -> IO ()) -> Control -> IO ()
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
        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 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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeDataFrame FrameHeader
header ByteString
bs
    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
    -- Empty Frame Flooding - CVE-2019-9518
    if ByteString
body ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
endOfStream (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"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 a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
body
    if Bool
endOfStream then do
        case Maybe 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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
streamId
        -- no trailers
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
        StreamState -> IO StreamState
forall (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 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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
endOfHeader then do
        -- Empty Frame Flooding - CVE-2019-9518
        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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
EnhanceYourCalm ByteString
"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 e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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 ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
rfrags'
            (TokenHeaderList, ValueTable)
tbl <- ByteString -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader ByteString
hdrblk 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
                        OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
NoBody (TokenHeaderList, ValueTable)
tbl)
                       else
                        OpenState -> StreamState
Open ((TokenHeaderList, ValueTable) -> OpenState
HasBody (TokenHeaderList, ValueTable)
tbl)
          else
            StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (OpenState -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString] -> 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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    Int
w <- STM Int -> IO Int
forall a. STM a -> IO a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
      Int
w0 <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
streamWindow
      let w1 :: Int
w1 = Int
w0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
      TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
streamWindow Int
w1
      Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w1
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
FlowControlError Int
streamId
    StreamState -> IO StreamState
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 <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
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
    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
$ ClosedCode -> StreamState
Closed ClosedCode
cc -- will be written to streamState again

stream FrameTypeId
FramePriority FrameHeader
header ByteString
bs Context
_ StreamState
s Stream{Int
streamNumber :: Int
streamNumber :: Stream -> Int
streamNumber} = do
    -- ignore
    -- Resource Loop - CVE-2019-9513
    PriorityFrame Priority
newpri <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error 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

-- this ordering is important
stream FrameTypeId
FrameContinuation FrameHeader
_ ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
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
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"an illegal frame follows header/continuation frames"
-- Ignore frames to streams we have just reset, per section 5.1.
stream FrameTypeId
_ 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 FrameTypeId
FrameData FrameHeader{Int
streamId :: Int
streamId :: FrameHeader -> Int
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
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
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> Int -> HTTP2Error
StreamError ErrorCodeId
ProtocolError Int
streamId

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

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

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

updateWindow :: TQueue Control -> StreamId -> Int -> IO ()
updateWindow :: TQueue Control -> Int -> Int -> IO ()
updateWindow TQueue Control
_        Int
_   Int
0   = () -> IO ()
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 (Control -> IO ()) -> Control -> IO ()
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 -> IO ByteString
readSource (Source Int -> IO ()
update TQueue ByteString
q IORef ByteString
refBS IORef Bool
refEOF) = do
    Bool
eof <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
refEOF
    if Bool
eof then
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
      else do
        ByteString
bs <- IO ByteString
readBS
        let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
        Int -> IO ()
update Int
len
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
  where
    readBS :: IO ByteString
readBS = do
        ByteString
bs0 <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
refBS
        if ByteString
bs0 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then do
            ByteString
bs <- STM ByteString -> IO ByteString
forall a. STM a -> IO a
atomically (STM ByteString -> IO ByteString)
-> STM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> STM ByteString
forall a. TQueue a -> STM a
readTQueue TQueue ByteString
q
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
refEOF Bool
True
            ByteString -> IO ByteString
forall (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