{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HTTP2.H2.Window where

import Data.IORef
import Network.Control
import qualified UnliftIO.Exception as E
import UnliftIO.STM

import Imports
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.EncodeFrame
import Network.HTTP2.H2.Queue
import Network.HTTP2.H2.Types

getStreamWindowSize :: Stream -> IO WindowSize
getStreamWindowSize :: Stream -> IO Int
getStreamWindowSize Stream{TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow} =
    TxFlow -> Int
txWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar TxFlow
streamTxFlow

getConnectionWindowSize :: Context -> IO WindowSize
getConnectionWindowSize :: Context -> IO Int
getConnectionWindowSize Context{TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow :: TVar TxFlow
txFlow} =
    TxFlow -> Int
txWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar TxFlow
txFlow

waitStreamWindowSize :: Stream -> IO ()
waitStreamWindowSize :: Stream -> IO ()
waitStreamWindowSize Stream{TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow} = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
    Int
w <- TxFlow -> Int
txWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar TxFlow
streamTxFlow
    Bool -> STM ()
checkSTM (Int
w forall a. Ord a => a -> a -> Bool
> Int
0)

waitConnectionWindowSize :: Context -> STM ()
waitConnectionWindowSize :: Context -> STM ()
waitConnectionWindowSize Context{TVar TxFlow
txFlow :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} = do
    Int
w <- TxFlow -> Int
txWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar TxFlow
txFlow
    Bool -> STM ()
checkSTM (Int
w forall a. Ord a => a -> a -> Bool
> Int
0)

----------------------------------------------------------------
-- Receiving window update

increaseWindowSize :: StreamId -> TVar TxFlow -> WindowSize -> IO ()
increaseWindowSize :: Int -> TVar TxFlow -> Int -> IO ()
increaseWindowSize Int
sid TVar TxFlow
tvar Int
n = do
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar TxFlow
tvar forall a b. (a -> b) -> a -> b
$ \TxFlow
flow -> TxFlow
flow{txfLimit :: Int
txfLimit = TxFlow -> Int
txfLimit TxFlow
flow forall a. Num a => a -> a -> a
+ Int
n}
    Int
w <- TxFlow -> Int
txWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar TxFlow
tvar
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isWindowOverflow Int
w) forall a b. (a -> b) -> a -> b
$ do
        let msg :: ReasonPhrase
msg = forall a. IsString a => String -> a
fromString (String
"window update for stream " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
sid forall a. [a] -> [a] -> [a]
++ String
" is overflow")
            err :: ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
err =
                if Int -> Bool
isControl Int
sid
                    then ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
                    else ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
err ErrorCode
FlowControlError Int
sid ReasonPhrase
msg

increaseStreamWindowSize :: Stream -> WindowSize -> IO ()
increaseStreamWindowSize :: Stream -> Int -> IO ()
increaseStreamWindowSize Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber, TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow} Int
n =
    Int -> TVar TxFlow -> Int -> IO ()
increaseWindowSize Int
streamNumber TVar TxFlow
streamTxFlow Int
n

increaseConnectionWindowSize :: Context -> Int -> IO ()
increaseConnectionWindowSize :: Context -> Int -> IO ()
increaseConnectionWindowSize Context{TVar TxFlow
txFlow :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} Int
n =
    Int -> TVar TxFlow -> Int -> IO ()
increaseWindowSize Int
0 TVar TxFlow
txFlow Int
n

decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()
decreaseWindowSize :: Context -> Stream -> Int -> IO ()
decreaseWindowSize Context{TVar TxFlow
txFlow :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} Stream{TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow} Int
siz = do
    forall {m :: * -> *}. MonadIO m => TVar TxFlow -> m ()
dec TVar TxFlow
txFlow
    forall {m :: * -> *}. MonadIO m => TVar TxFlow -> m ()
dec TVar TxFlow
streamTxFlow
  where
    dec :: TVar TxFlow -> m ()
dec TVar TxFlow
tvar = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar TxFlow
tvar forall a b. (a -> b) -> a -> b
$ \TxFlow
flow -> TxFlow
flow{txfSent :: Int
txfSent = TxFlow -> Int
txfSent TxFlow
flow forall a. Num a => a -> a -> a
+ Int
siz}

----------------------------------------------------------------
-- Sending window update

informWindowUpdate :: Context -> Stream -> Int -> IO ()
informWindowUpdate :: Context -> Stream -> Int -> IO ()
informWindowUpdate Context
_ Stream
_ Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
informWindowUpdate Context{TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ, IORef RxFlow
rxFlow :: Context -> IORef RxFlow
rxFlow :: IORef RxFlow
rxFlow} Stream{Int
streamNumber :: Int
streamNumber :: Stream -> Int
streamNumber, IORef RxFlow
streamRxFlow :: Stream -> IORef RxFlow
streamRxFlow :: IORef RxFlow
streamRxFlow} Int
len = do
    Maybe Int
mxc <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef RxFlow
rxFlow forall a b. (a -> b) -> a -> b
$ Int -> FlowControlType -> RxFlow -> (RxFlow, Maybe Int)
maybeOpenRxWindow Int
len FlowControlType
FCTWindowUpdate
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
mxc forall a b. (a -> b) -> a -> b
$ \Int
ws -> do
        let frame :: ByteString
frame = Int -> Int -> ByteString
windowUpdateFrame Int
0 Int
ws
            cframe :: Control
cframe = Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame]
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
cframe
    Maybe Int
mxs <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef RxFlow
streamRxFlow forall a b. (a -> b) -> a -> b
$ Int -> FlowControlType -> RxFlow -> (RxFlow, Maybe Int)
maybeOpenRxWindow Int
len FlowControlType
FCTWindowUpdate
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
mxs forall a b. (a -> b) -> a -> b
$ \Int
ws -> do
        let frame :: ByteString
frame = Int -> Int -> ByteString
windowUpdateFrame Int
streamNumber Int
ws
            cframe :: Control
cframe = Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
frame]
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
cframe