{-# LANGUAGE RecordWildCards #-}

module Network.HTTP2.H2.StreamTable (
    -- * Types
    OddStreamTable (..),
    emptyOddStreamTable,
    EvenStreamTable (..),
    emptyEvenStreamTable,

    -- * Odd
    insertOdd,
    insertOdd',
    deleteOdd,
    lookupOdd,
    getOddConcurrency,
    getOddStreams,
    clearOddStreamTable,
    waitIncOdd,

    -- * Even
    insertEven,
    insertEven',
    deleteEven,
    lookupEven,
    getEvenConcurrency,
    clearEvenStreamTable,
    waitIncEven,
    insertEvenCache,
    deleteEvenCache,
    lookupEvenCache,
    getEvenStreams,
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Network.Control (LRUCache)
import qualified Network.Control as LRUCache
import Network.HTTP.Types (Method)

import Imports
import Network.HTTP2.H2.Types (Stream (..))

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

data OddStreamTable = OddStreamTable
    { OddStreamTable -> Int
oddConc :: Int
    , OddStreamTable -> IntMap Stream
oddTable :: IntMap Stream
    }

emptyOddStreamTable :: OddStreamTable
emptyOddStreamTable :: OddStreamTable
emptyOddStreamTable = Int -> IntMap Stream -> OddStreamTable
OddStreamTable Int
0 forall a. IntMap a
IntMap.empty

data EvenStreamTable = EvenStreamTable
    { EvenStreamTable -> Int
evenConc :: Int
    , EvenStreamTable -> IntMap Stream
evenTable :: IntMap Stream
    , -- Cache must contain Stream instead of StreamId because
      -- a Stream is deleted when end-of-stream is received.
      -- After that, cache is looked up.
      EvenStreamTable -> LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, ByteString) Stream
    }

emptyEvenStreamTable :: Int -> EvenStreamTable
emptyEvenStreamTable :: Int -> EvenStreamTable
emptyEvenStreamTable Int
lim = Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
0 forall a. IntMap a
IntMap.empty forall a b. (a -> b) -> a -> b
$ forall k v. Int -> LRUCache k v
LRUCache.empty Int
lim

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

insertOdd :: TVar OddStreamTable -> IntMap.Key -> Stream -> IO ()
insertOdd :: TVar OddStreamTable -> Int -> Stream -> IO ()
insertOdd TVar OddStreamTable
var Int
k Stream
v = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar OddStreamTable
var forall a b. (a -> b) -> a -> b
$ \OddStreamTable{Int
IntMap Stream
oddTable :: IntMap Stream
oddConc :: Int
oddTable :: OddStreamTable -> IntMap Stream
oddConc :: OddStreamTable -> Int
..} ->
    let oddConc' :: Int
oddConc' = Int
oddConc forall a. Num a => a -> a -> a
+ Int
1
        oddTable' :: IntMap Stream
oddTable' = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k Stream
v IntMap Stream
oddTable
     in Int -> IntMap Stream -> OddStreamTable
OddStreamTable Int
oddConc' IntMap Stream
oddTable'

insertOdd' :: TVar OddStreamTable -> IntMap.Key -> Stream -> IO ()
insertOdd' :: TVar OddStreamTable -> Int -> Stream -> IO ()
insertOdd' TVar OddStreamTable
var Int
k Stream
v = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar OddStreamTable
var forall a b. (a -> b) -> a -> b
$ \OddStreamTable{Int
IntMap Stream
oddTable :: IntMap Stream
oddConc :: Int
oddTable :: OddStreamTable -> IntMap Stream
oddConc :: OddStreamTable -> Int
..} ->
    let oddTable' :: IntMap Stream
oddTable' = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k Stream
v IntMap Stream
oddTable
     in Int -> IntMap Stream -> OddStreamTable
OddStreamTable Int
oddConc IntMap Stream
oddTable'

deleteOdd :: TVar OddStreamTable -> IntMap.Key -> SomeException -> IO ()
deleteOdd :: TVar OddStreamTable -> Int -> SomeException -> IO ()
deleteOdd TVar OddStreamTable
var Int
k SomeException
err = do
    Maybe Stream
mv <- forall a. STM a -> IO a
atomically STM (Maybe Stream)
deleteStream
    case Maybe Stream
mv of
        Maybe Stream
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- Stream was already removed
        Just Stream
v -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> a -> IO Bool
tryPutMVar (Stream -> MVar (Either SomeException InpObj)
streamInput Stream
v) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left SomeException
err
  where
    deleteStream :: STM (Maybe Stream)
    deleteStream :: STM (Maybe Stream)
deleteStream = do
        OddStreamTable{Int
IntMap Stream
oddTable :: IntMap Stream
oddConc :: Int
oddTable :: OddStreamTable -> IntMap Stream
oddConc :: OddStreamTable -> Int
..} <- forall a. TVar a -> STM a
readTVar TVar OddStreamTable
var
        let oddConc' :: Int
oddConc' = Int
oddConc forall a. Num a => a -> a -> a
- Int
1
            oddTable' :: IntMap Stream
oddTable' = forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
k IntMap Stream
oddTable
        forall a. TVar a -> a -> STM ()
writeTVar TVar OddStreamTable
var forall a b. (a -> b) -> a -> b
$ Int -> IntMap Stream -> OddStreamTable
OddStreamTable Int
oddConc' IntMap Stream
oddTable'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap Stream
oddTable

lookupOdd :: TVar OddStreamTable -> IntMap.Key -> IO (Maybe Stream)
lookupOdd :: TVar OddStreamTable -> Int -> IO (Maybe Stream)
lookupOdd TVar OddStreamTable
var Int
k = forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. OddStreamTable -> IntMap Stream
oddTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar OddStreamTable
var

getOddConcurrency :: TVar OddStreamTable -> IO Int
getOddConcurrency :: TVar OddStreamTable -> IO Int
getOddConcurrency TVar OddStreamTable
var = OddStreamTable -> Int
oddConc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar OddStreamTable
var

getOddStreams :: TVar OddStreamTable -> IO (IntMap Stream)
getOddStreams :: TVar OddStreamTable -> IO (IntMap Stream)
getOddStreams TVar OddStreamTable
var = OddStreamTable -> IntMap Stream
oddTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar OddStreamTable
var

clearOddStreamTable :: TVar OddStreamTable -> IO (IntMap Stream)
clearOddStreamTable :: TVar OddStreamTable -> IO (IntMap Stream)
clearOddStreamTable TVar OddStreamTable
var = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    OddStreamTable{Int
IntMap Stream
oddTable :: IntMap Stream
oddConc :: Int
oddTable :: OddStreamTable -> IntMap Stream
oddConc :: OddStreamTable -> Int
..} <- forall a. TVar a -> STM a
readTVar TVar OddStreamTable
var
    forall a. TVar a -> a -> STM ()
writeTVar TVar OddStreamTable
var OddStreamTable
emptyOddStreamTable
    forall (m :: * -> *) a. Monad m => a -> m a
return IntMap Stream
oddTable

waitIncOdd :: TVar OddStreamTable -> Int -> STM ()
waitIncOdd :: TVar OddStreamTable -> Int -> STM ()
waitIncOdd TVar OddStreamTable
var Int
maxConc = do
    OddStreamTable{Int
IntMap Stream
oddTable :: IntMap Stream
oddConc :: Int
oddTable :: OddStreamTable -> IntMap Stream
oddConc :: OddStreamTable -> Int
..} <- forall a. TVar a -> STM a
readTVar TVar OddStreamTable
var
    Bool -> STM ()
check (Int
oddConc forall a. Ord a => a -> a -> Bool
< Int
maxConc)
    let oddConc' :: Int
oddConc' = Int
oddConc forall a. Num a => a -> a -> a
+ Int
1
    forall a. TVar a -> a -> STM ()
writeTVar TVar OddStreamTable
var forall a b. (a -> b) -> a -> b
$ Int -> IntMap Stream -> OddStreamTable
OddStreamTable Int
oddConc' IntMap Stream
oddTable

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

insertEven :: TVar EvenStreamTable -> IntMap.Key -> Stream -> IO ()
insertEven :: TVar EvenStreamTable -> Int -> Stream -> IO ()
insertEven TVar EvenStreamTable
var Int
k Stream
v = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ \EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} ->
    let evenConc' :: Int
evenConc' = Int
evenConc forall a. Num a => a -> a -> a
+ Int
1
        evenTable' :: IntMap Stream
evenTable' = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k Stream
v IntMap Stream
evenTable
     in Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
evenConc' IntMap Stream
evenTable' LRUCache (Method, Method) Stream
evenCache

insertEven' :: TVar EvenStreamTable -> IntMap.Key -> Stream -> IO ()
insertEven' :: TVar EvenStreamTable -> Int -> Stream -> IO ()
insertEven' TVar EvenStreamTable
var Int
k Stream
v = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ \EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} ->
    let evenTable' :: IntMap Stream
evenTable' = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k Stream
v IntMap Stream
evenTable
     in Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
evenConc IntMap Stream
evenTable' LRUCache (Method, Method) Stream
evenCache

deleteEven :: TVar EvenStreamTable -> IntMap.Key -> SomeException -> IO ()
deleteEven :: TVar EvenStreamTable -> Int -> SomeException -> IO ()
deleteEven TVar EvenStreamTable
var Int
k SomeException
err = do
    Maybe Stream
mv <- forall a. STM a -> IO a
atomically STM (Maybe Stream)
deleteStream
    case Maybe Stream
mv of
        Maybe Stream
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- Stream was already removed
        Just Stream
v -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> a -> IO Bool
tryPutMVar (Stream -> MVar (Either SomeException InpObj)
streamInput Stream
v) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left SomeException
err
  where
    deleteStream :: STM (Maybe Stream)
    deleteStream :: STM (Maybe Stream)
deleteStream = do
        EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} <- forall a. TVar a -> STM a
readTVar TVar EvenStreamTable
var
        let evenConc' :: Int
evenConc' = Int
evenConc forall a. Num a => a -> a -> a
- Int
1
            evenTable' :: IntMap Stream
evenTable' = forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
k IntMap Stream
evenTable
        forall a. TVar a -> a -> STM ()
writeTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
evenConc' IntMap Stream
evenTable' LRUCache (Method, Method) Stream
evenCache
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap Stream
evenTable

lookupEven :: TVar EvenStreamTable -> IntMap.Key -> IO (Maybe Stream)
lookupEven :: TVar EvenStreamTable -> Int -> IO (Maybe Stream)
lookupEven TVar EvenStreamTable
var Int
k = forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvenStreamTable -> IntMap Stream
evenTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar EvenStreamTable
var

getEvenConcurrency :: TVar EvenStreamTable -> IO Int
getEvenConcurrency :: TVar EvenStreamTable -> IO Int
getEvenConcurrency TVar EvenStreamTable
var = EvenStreamTable -> Int
evenConc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar EvenStreamTable
var

clearEvenStreamTable :: TVar EvenStreamTable -> IO (IntMap Stream)
clearEvenStreamTable :: TVar EvenStreamTable -> IO (IntMap Stream)
clearEvenStreamTable TVar EvenStreamTable
var = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} <- forall a. TVar a -> STM a
readTVar TVar EvenStreamTable
var
    forall a. TVar a -> a -> STM ()
writeTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ Int -> EvenStreamTable
emptyEvenStreamTable Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return IntMap Stream
evenTable

waitIncEven :: TVar EvenStreamTable -> Int -> STM ()
waitIncEven :: TVar EvenStreamTable -> Int -> STM ()
waitIncEven TVar EvenStreamTable
var Int
maxConc = do
    EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} <- forall a. TVar a -> STM a
readTVar TVar EvenStreamTable
var
    Bool -> STM ()
check (Int
evenConc forall a. Ord a => a -> a -> Bool
< Int
maxConc)
    let evenConc' :: Int
evenConc' = Int
evenConc forall a. Num a => a -> a -> a
+ Int
1
    forall a. TVar a -> a -> STM ()
writeTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
evenConc' IntMap Stream
evenTable LRUCache (Method, Method) Stream
evenCache

insertEvenCache
    :: TVar EvenStreamTable -> Method -> ByteString -> Stream -> IO ()
insertEvenCache :: TVar EvenStreamTable -> Method -> Method -> Stream -> IO ()
insertEvenCache TVar EvenStreamTable
var Method
method Method
path strm :: Stream
strm@Stream{Int
TVar TxFlow
IORef RxFlow
IORef StreamState
MVar (Either SomeException InpObj)
streamRxFlow :: Stream -> IORef RxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamState :: Stream -> IORef StreamState
streamNumber :: Stream -> Int
streamRxFlow :: IORef RxFlow
streamTxFlow :: TVar TxFlow
streamInput :: MVar (Either SomeException InpObj)
streamState :: IORef StreamState
streamNumber :: Int
streamInput :: Stream -> MVar (Either SomeException InpObj)
..} = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ \EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} ->
    let evenConc' :: Int
evenConc' = Int
evenConc forall a. Num a => a -> a -> a
+ Int
1
        evenTable' :: IntMap Stream
evenTable' = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
streamNumber Stream
strm IntMap Stream
evenTable
        evenCache' :: LRUCache (Method, Method) Stream
evenCache' = forall k v. Ord k => k -> v -> LRUCache k v -> LRUCache k v
LRUCache.insert (Method
method, Method
path) Stream
strm LRUCache (Method, Method) Stream
evenCache
     in Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
evenConc' IntMap Stream
evenTable' LRUCache (Method, Method) Stream
evenCache'

deleteEvenCache :: TVar EvenStreamTable -> Method -> ByteString -> IO ()
deleteEvenCache :: TVar EvenStreamTable -> Method -> Method -> IO ()
deleteEvenCache TVar EvenStreamTable
var Method
m Method
path = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar EvenStreamTable
var forall a b. (a -> b) -> a -> b
$ \EvenStreamTable{Int
IntMap Stream
LRUCache (Method, Method) Stream
evenCache :: LRUCache (Method, Method) Stream
evenTable :: IntMap Stream
evenConc :: Int
evenCache :: EvenStreamTable -> LRUCache (Method, Method) Stream
evenTable :: EvenStreamTable -> IntMap Stream
evenConc :: EvenStreamTable -> Int
..} ->
    let evenCache' :: LRUCache (Method, Method) Stream
evenCache' = forall k v. Ord k => k -> LRUCache k v -> LRUCache k v
LRUCache.delete (Method
m, Method
path) LRUCache (Method, Method) Stream
evenCache
     in Int
-> IntMap Stream
-> LRUCache (Method, Method) Stream
-> EvenStreamTable
EvenStreamTable Int
evenConc IntMap Stream
evenTable LRUCache (Method, Method) Stream
evenCache'

lookupEvenCache
    :: TVar EvenStreamTable -> Method -> ByteString -> IO (Maybe Stream)
lookupEvenCache :: TVar EvenStreamTable -> Method -> Method -> IO (Maybe Stream)
lookupEvenCache TVar EvenStreamTable
var Method
m Method
path = forall k v. Ord k => k -> LRUCache k v -> Maybe v
LRUCache.lookup (Method
m, Method
path) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvenStreamTable -> LRUCache (Method, Method) Stream
evenCache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar EvenStreamTable
var

getEvenStreams :: TVar EvenStreamTable -> IO (IntMap Stream)
getEvenStreams :: TVar EvenStreamTable -> IO (IntMap Stream)
getEvenStreams TVar EvenStreamTable
var = EvenStreamTable -> IntMap Stream
evenTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar EvenStreamTable
var