{-# 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 :: TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow} =
    TxFlow -> Int
txWindowSize (TxFlow -> Int) -> IO TxFlow -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar TxFlow -> IO TxFlow
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 :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} =
    TxFlow -> Int
txWindowSize (TxFlow -> Int) -> IO TxFlow -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar TxFlow -> IO TxFlow
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar TxFlow
txFlow

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

waitConnectionWindowSize :: Context -> STM ()
waitConnectionWindowSize :: Context -> STM ()
waitConnectionWindowSize Context{TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow :: TVar TxFlow
txFlow} = do
    Int
w <- TxFlow -> Int
txWindowSize (TxFlow -> Int) -> STM TxFlow -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar TxFlow -> STM TxFlow
forall a. TVar a -> STM a
readTVar TVar TxFlow
txFlow
    Bool -> STM ()
checkSTM (Int
w Int -> Int -> Bool
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
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar TxFlow -> (TxFlow -> TxFlow) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar TxFlow
tvar ((TxFlow -> TxFlow) -> STM ()) -> (TxFlow -> TxFlow) -> STM ()
forall a b. (a -> b) -> a -> b
$ \TxFlow
flow -> TxFlow
flow{txfLimit = txfLimit flow + n}
    Int
w <- TxFlow -> Int
txWindowSize (TxFlow -> Int) -> IO TxFlow -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar TxFlow -> IO TxFlow
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar TxFlow
tvar
    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
$ do
        let msg :: ReasonPhrase
msg = String -> ReasonPhrase
forall a. IsString a => String -> a
fromString (String
"window update for stream " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sid String -> String -> String
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
        HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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 :: Int
streamNumber :: Stream -> Int
streamNumber, TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow :: 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 :: Context -> TVar TxFlow
txFlow :: 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 :: Context -> TVar TxFlow
txFlow :: TVar TxFlow
txFlow} Stream{TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow} Int
siz = do
    TVar TxFlow -> IO ()
forall {m :: * -> *}. MonadIO m => TVar TxFlow -> m ()
dec TVar TxFlow
txFlow
    TVar TxFlow -> IO ()
forall {m :: * -> *}. MonadIO m => TVar TxFlow -> m ()
dec TVar TxFlow
streamTxFlow
  where
    dec :: TVar TxFlow -> m ()
dec TVar TxFlow
tvar = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar TxFlow -> (TxFlow -> TxFlow) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar TxFlow
tvar ((TxFlow -> TxFlow) -> STM ()) -> (TxFlow -> TxFlow) -> STM ()
forall a b. (a -> b) -> a -> b
$ \TxFlow
flow -> TxFlow
flow{txfSent = txfSent flow + siz}

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

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