{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
module Network.HTTP2.Server.Context where
import Control.Concurrent.STM
import Data.IORef
import Imports
import Network.HPACK
import Network.HTTP2
import Network.HTTP2.Priority
import Network.HTTP2.Server.Stream
import Network.HTTP2.Server.Types
data Context = Context {
Context -> IORef Settings
http2settings :: !(IORef Settings)
, Context -> IORef Bool
firstSettings :: !(IORef Bool)
, Context -> StreamTable
streamTable :: !StreamTable
, Context -> IORef Int
concurrency :: !(IORef Int)
, Context -> IORef Int
priorityTreeSize :: !(IORef Int)
, Context -> IORef (Maybe Int)
continued :: !(IORef (Maybe StreamId))
, Context -> IORef Int
clientStreamId :: !(IORef StreamId)
, Context -> IORef Int
serverStreamId :: !(IORef StreamId)
, Context -> TQueue Input
inputQ :: !(TQueue Input)
, Context -> PriorityTree Output
outputQ :: !(PriorityTree Output)
, Context -> TQueue Control
controlQ :: !(TQueue Control)
, Context -> DynamicTable
encodeDynamicTable :: !DynamicTable
, Context -> DynamicTable
decodeDynamicTable :: !DynamicTable
, Context -> TVar Int
connectionWindow :: !(TVar WindowSize)
}
newContext :: IO Context
newContext :: IO Context
newContext = IORef Settings
-> IORef Bool
-> StreamTable
-> IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context
Context (IORef Settings
-> IORef Bool
-> StreamTable
-> IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef Settings)
-> IO
(IORef Bool
-> StreamTable
-> IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> IO (IORef Settings)
forall a. a -> IO (IORef a)
newIORef Settings
defaultSettings
IO
(IORef Bool
-> StreamTable
-> IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef Bool)
-> IO
(StreamTable
-> IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
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
IO
(StreamTable
-> IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO StreamTable
-> IO
(IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO StreamTable
newStreamTable
IO
(IORef Int
-> IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef Int)
-> IO
(IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IO
(IORef Int
-> IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef Int)
-> IO
(IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IO
(IORef (Maybe Int)
-> IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef (Maybe Int))
-> IO
(IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int -> IO (IORef (Maybe Int))
forall a. a -> IO (IORef a)
newIORef Maybe Int
forall a. Maybe a
Nothing
IO
(IORef Int
-> IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef Int)
-> IO
(IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IO
(IORef Int
-> TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (IORef Int)
-> IO
(TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IO
(TQueue Input
-> PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (TQueue Input)
-> IO
(PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TQueue Input)
forall a. IO (TQueue a)
newTQueueIO
IO
(PriorityTree Output
-> TQueue Control
-> DynamicTable
-> DynamicTable
-> TVar Int
-> Context)
-> IO (PriorityTree Output)
-> IO
(TQueue Control
-> DynamicTable -> DynamicTable -> TVar Int -> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (PriorityTree Output)
forall a. IO (PriorityTree a)
newPriorityTree
IO
(TQueue Control
-> DynamicTable -> DynamicTable -> TVar Int -> Context)
-> IO (TQueue Control)
-> IO (DynamicTable -> DynamicTable -> TVar Int -> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TQueue Control)
forall a. IO (TQueue a)
newTQueueIO
IO (DynamicTable -> DynamicTable -> TVar Int -> Context)
-> IO DynamicTable -> IO (DynamicTable -> TVar Int -> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO DynamicTable
newDynamicTableForEncoding Int
defaultDynamicTableSize
IO (DynamicTable -> TVar Int -> Context)
-> IO DynamicTable -> IO (TVar Int -> Context)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> IO DynamicTable
newDynamicTableForDecoding Int
defaultDynamicTableSize Int
4096
IO (TVar Int -> Context) -> IO (TVar Int) -> IO Context
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
defaultInitialWindowSize
clearContext :: Context -> IO ()
clearContext :: Context -> IO ()
clearContext Context
ctx = do
DynamicTable -> IO ()
clearDynamicTable (DynamicTable -> IO ()) -> DynamicTable -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> DynamicTable
encodeDynamicTable Context
ctx
DynamicTable -> IO ()
clearDynamicTable (DynamicTable -> IO ()) -> DynamicTable -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> DynamicTable
decodeDynamicTable Context
ctx
newPushStream :: Context -> WindowSize -> Precedence -> IO Stream
newPushStream :: Context -> Int -> Precedence -> IO Stream
newPushStream Context{IORef Int
serverStreamId :: IORef Int
serverStreamId :: Context -> IORef Int
serverStreamId} Int
win Precedence
pre = do
Int
sid <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
serverStreamId Int -> (Int, Int)
forall b. Num b => b -> (b, b)
inc2
Int -> IORef StreamState -> TVar Int -> IORef Precedence -> Stream
Stream Int
sid (IORef StreamState -> TVar Int -> IORef Precedence -> Stream)
-> IO (IORef StreamState)
-> IO (TVar Int -> IORef Precedence -> Stream)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StreamState -> IO (IORef StreamState)
forall a. a -> IO (IORef a)
newIORef StreamState
Reserved
IO (TVar Int -> IORef Precedence -> Stream)
-> IO (TVar Int) -> IO (IORef Precedence -> Stream)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
win
IO (IORef Precedence -> Stream)
-> IO (IORef Precedence) -> IO Stream
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence -> IO (IORef Precedence)
forall a. a -> IO (IORef a)
newIORef Precedence
pre
where
inc2 :: b -> (b, b)
inc2 b
x = let !x' :: b
x' = b
x b -> b -> b
forall a. Num a => a -> a -> a
+ b
2 in (b
x', b
x')
{-# INLINE setStreamState #-}
setStreamState :: Context -> Stream -> StreamState -> IO ()
setStreamState :: Context -> Stream -> StreamState -> IO ()
setStreamState Context
_ Stream{IORef StreamState
streamState :: Stream -> IORef StreamState
streamState :: IORef StreamState
streamState} StreamState
val = IORef StreamState -> StreamState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef StreamState
streamState StreamState
val
opened :: Context -> Stream -> IO ()
opened :: Context -> Stream -> IO ()
opened ctx :: Context
ctx@Context{IORef Int
concurrency :: IORef Int
concurrency :: Context -> IORef Int
concurrency} Stream
strm = do
IORef Int -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
concurrency (\Int
x -> (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,()))
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm (OpenState -> StreamState
Open OpenState
JustOpened)
halfClosedRemote :: Context -> Stream -> IO ()
halfClosedRemote :: Context -> Stream -> IO ()
halfClosedRemote Context
ctx stream :: Stream
stream@Stream{IORef StreamState
streamState :: IORef StreamState
streamState :: Stream -> IORef StreamState
streamState} = do
!Maybe ClosedCode
closingCode <- IORef StreamState
-> (StreamState -> (StreamState, Maybe ClosedCode))
-> IO (Maybe ClosedCode)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef StreamState
streamState StreamState -> (StreamState, Maybe ClosedCode)
closeHalf
(ClosedCode -> IO ()) -> Maybe ClosedCode -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
stream) Maybe ClosedCode
closingCode
where
closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)
closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)
closeHalf x :: StreamState
x@(Closed ClosedCode
_) = (StreamState
x, Maybe ClosedCode
forall a. Maybe a
Nothing)
closeHalf (HalfClosedLocal ClosedCode
cc) = (ClosedCode -> StreamState
Closed ClosedCode
cc, ClosedCode -> Maybe ClosedCode
forall a. a -> Maybe a
Just ClosedCode
cc)
closeHalf StreamState
_ = (StreamState
HalfClosedRemote, Maybe ClosedCode
forall a. Maybe a
Nothing)
halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx stream :: Stream
stream@Stream{IORef StreamState
streamState :: IORef StreamState
streamState :: Stream -> IORef StreamState
streamState} ClosedCode
cc = do
Bool
shouldFinalize <- IORef StreamState
-> (StreamState -> (StreamState, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef StreamState
streamState StreamState -> (StreamState, Bool)
closeHalf
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldFinalize (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
stream ClosedCode
cc
where
closeHalf :: StreamState -> (StreamState, Bool)
closeHalf :: StreamState -> (StreamState, Bool)
closeHalf x :: StreamState
x@(Closed ClosedCode
_) = (StreamState
x, Bool
False)
closeHalf StreamState
HalfClosedRemote = (ClosedCode -> StreamState
Closed ClosedCode
cc, Bool
True)
closeHalf StreamState
_ = (ClosedCode -> StreamState
HalfClosedLocal ClosedCode
cc, Bool
False)
closed :: Context -> Stream -> ClosedCode -> IO ()
closed :: Context -> Stream -> ClosedCode -> IO ()
closed ctx :: Context
ctx@Context{IORef Int
concurrency :: IORef Int
concurrency :: Context -> IORef Int
concurrency,StreamTable
streamTable :: StreamTable
streamTable :: Context -> StreamTable
streamTable} strm :: Stream
strm@Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber} ClosedCode
cc = do
StreamTable -> Int -> IO ()
remove StreamTable
streamTable Int
streamNumber
IORef Int -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
concurrency (\Int
x -> (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,()))
Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm (ClosedCode -> StreamState
Closed ClosedCode
cc)