{-# 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 WindowSize
getStreamWindowSize Stream{TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow} =
TxFlow -> WindowSize
txWindowSize (TxFlow -> WindowSize) -> IO TxFlow -> IO WindowSize
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 WindowSize
getConnectionWindowSize Context{TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow :: TVar TxFlow
txFlow} =
TxFlow -> WindowSize
txWindowSize (TxFlow -> WindowSize) -> IO TxFlow -> IO WindowSize
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 :: TVar TxFlow
streamTxFlow :: Stream -> 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
WindowSize
w <- TxFlow -> WindowSize
txWindowSize (TxFlow -> WindowSize) -> STM TxFlow -> STM WindowSize
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 (WindowSize
w WindowSize -> WindowSize -> Bool
forall a. Ord a => a -> a -> Bool
> WindowSize
0)
waitConnectionWindowSize :: Context -> STM ()
waitConnectionWindowSize :: Context -> STM ()
waitConnectionWindowSize Context{TVar TxFlow
txFlow :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} = do
WindowSize
w <- TxFlow -> WindowSize
txWindowSize (TxFlow -> WindowSize) -> STM TxFlow -> STM WindowSize
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 (WindowSize
w WindowSize -> WindowSize -> Bool
forall a. Ord a => a -> a -> Bool
> WindowSize
0)
increaseWindowSize :: StreamId -> TVar TxFlow -> WindowSize -> IO ()
increaseWindowSize :: WindowSize -> TVar TxFlow -> WindowSize -> IO ()
increaseWindowSize WindowSize
sid TVar TxFlow
tvar WindowSize
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 :: WindowSize
txfLimit = TxFlow -> WindowSize
txfLimit TxFlow
flow WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
n}
WindowSize
w <- TxFlow -> WindowSize
txWindowSize (TxFlow -> WindowSize) -> IO TxFlow -> IO WindowSize
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 (WindowSize -> Bool
isWindowOverflow WindowSize
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]
++ WindowSize -> String
forall a. Show a => a -> String
show WindowSize
sid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is overflow")
err :: ErrorCode -> WindowSize -> ReasonPhrase -> HTTP2Error
err =
if WindowSize -> Bool
isControl WindowSize
sid
then ErrorCode -> WindowSize -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent
else ErrorCode -> WindowSize -> 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 -> WindowSize -> ReasonPhrase -> HTTP2Error
err ErrorCode
FlowControlError WindowSize
sid ReasonPhrase
msg
increaseStreamWindowSize :: Stream -> WindowSize -> IO ()
increaseStreamWindowSize :: Stream -> WindowSize -> IO ()
increaseStreamWindowSize Stream{WindowSize
streamNumber :: Stream -> WindowSize
streamNumber :: WindowSize
streamNumber, TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow} WindowSize
n =
WindowSize -> TVar TxFlow -> WindowSize -> IO ()
increaseWindowSize WindowSize
streamNumber TVar TxFlow
streamTxFlow WindowSize
n
increaseConnectionWindowSize :: Context -> Int -> IO ()
increaseConnectionWindowSize :: Context -> WindowSize -> IO ()
increaseConnectionWindowSize Context{TVar TxFlow
txFlow :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} WindowSize
n =
WindowSize -> TVar TxFlow -> WindowSize -> IO ()
increaseWindowSize WindowSize
0 TVar TxFlow
txFlow WindowSize
n
decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()
decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()
decreaseWindowSize Context{TVar TxFlow
txFlow :: TVar TxFlow
txFlow :: Context -> TVar TxFlow
txFlow} Stream{TVar TxFlow
streamTxFlow :: TVar TxFlow
streamTxFlow :: Stream -> TVar TxFlow
streamTxFlow} WindowSize
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 :: WindowSize
txfSent = TxFlow -> WindowSize
txfSent TxFlow
flow WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
siz}
informWindowUpdate :: Context -> Stream -> Int -> IO ()
informWindowUpdate :: Context -> Stream -> WindowSize -> IO ()
informWindowUpdate Context
_ Stream
_ WindowSize
0 = () -> IO ()
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{WindowSize
streamNumber :: WindowSize
streamNumber :: Stream -> WindowSize
streamNumber, IORef RxFlow
streamRxFlow :: Stream -> IORef RxFlow
streamRxFlow :: IORef RxFlow
streamRxFlow} WindowSize
len = do
Maybe WindowSize
mxc <- IORef RxFlow
-> (RxFlow -> (RxFlow, Maybe WindowSize)) -> IO (Maybe WindowSize)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef RxFlow
rxFlow ((RxFlow -> (RxFlow, Maybe WindowSize)) -> IO (Maybe WindowSize))
-> (RxFlow -> (RxFlow, Maybe WindowSize)) -> IO (Maybe WindowSize)
forall a b. (a -> b) -> a -> b
$ WindowSize
-> FlowControlType -> RxFlow -> (RxFlow, Maybe WindowSize)
maybeOpenRxWindow WindowSize
len FlowControlType
FCTWindowUpdate
Maybe WindowSize -> (WindowSize -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WindowSize
mxc ((WindowSize -> IO ()) -> IO ()) -> (WindowSize -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WindowSize
ws -> do
let frame :: ByteString
frame = WindowSize -> WindowSize -> ByteString
windowUpdateFrame WindowSize
0 WindowSize
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 WindowSize
mxs <- IORef RxFlow
-> (RxFlow -> (RxFlow, Maybe WindowSize)) -> IO (Maybe WindowSize)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef RxFlow
streamRxFlow ((RxFlow -> (RxFlow, Maybe WindowSize)) -> IO (Maybe WindowSize))
-> (RxFlow -> (RxFlow, Maybe WindowSize)) -> IO (Maybe WindowSize)
forall a b. (a -> b) -> a -> b
$ WindowSize
-> FlowControlType -> RxFlow -> (RxFlow, Maybe WindowSize)
maybeOpenRxWindow WindowSize
len FlowControlType
FCTWindowUpdate
Maybe WindowSize -> (WindowSize -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WindowSize
mxs ((WindowSize -> IO ()) -> IO ()) -> (WindowSize -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WindowSize
ws -> do
let frame :: ByteString
frame = WindowSize -> WindowSize -> ByteString
windowUpdateFrame WindowSize
streamNumber WindowSize
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