{-# 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

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

-- | The context for HTTP/2 connection.
data Context = Context {
  -- HTTP/2 settings received from a browser
    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)
  -- | RFC 7540 says "Other frames (from any stream) MUST NOT
  --   occur between the HEADERS frame and any CONTINUATION
  --   frames that might follow". This field is used to implement
  --   this requirement.
  , 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
  -- the connection window for data from a server to a browser.
  , 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
    -- TODO: prevent double-counting
    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) -- anyway