{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.Arch.Window where
import Data.IORef
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import Imports
import Network.HTTP2.Arch.Config
import Network.HTTP2.Arch.Context
import Network.HTTP2.Arch.EncodeFrame
import Network.HTTP2.Arch.Queue
import Network.HTTP2.Arch.Stream
import Network.HTTP2.Arch.Types
import Network.HTTP2.Frame
getStreamWindowSize :: Stream -> IO WindowSize
getStreamWindowSize :: Stream -> IO WindowSize
getStreamWindowSize Stream{TVar WindowSize
streamWindow :: TVar WindowSize
streamWindow :: Stream -> TVar WindowSize
streamWindow} = TVar WindowSize -> IO WindowSize
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar WindowSize
streamWindow
getConnectionWindowSize :: Context -> IO WindowSize
getConnectionWindowSize :: Context -> IO WindowSize
getConnectionWindowSize Context{TVar WindowSize
txConnectionWindow :: TVar WindowSize
txConnectionWindow :: Context -> TVar WindowSize
txConnectionWindow} = TVar WindowSize -> IO WindowSize
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar WindowSize
txConnectionWindow
waitStreamWindowSize :: Stream -> IO ()
waitStreamWindowSize :: Stream -> IO ()
waitStreamWindowSize Stream{TVar WindowSize
streamWindow :: Stream -> TVar WindowSize
streamWindow :: TVar WindowSize
streamWindow} = 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 <- TVar WindowSize -> STM WindowSize
forall a. TVar a -> STM a
readTVar TVar WindowSize
streamWindow
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 WindowSize
txConnectionWindow :: Context -> TVar WindowSize
txConnectionWindow :: TVar WindowSize
txConnectionWindow} = do
WindowSize
w <- TVar WindowSize -> STM WindowSize
forall a. TVar a -> STM a
readTVar TVar WindowSize
txConnectionWindow
Bool -> STM ()
checkSTM (WindowSize
w WindowSize -> WindowSize -> Bool
forall a. Ord a => a -> a -> Bool
> WindowSize
0)
increaseWindowSize :: StreamId -> TVar WindowSize -> WindowSize -> IO ()
increaseWindowSize :: WindowSize -> TVar WindowSize -> WindowSize -> IO ()
increaseWindowSize WindowSize
sid TVar WindowSize
tvar WindowSize
n = do
WindowSize
w <- STM WindowSize -> IO WindowSize
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM WindowSize -> IO WindowSize)
-> STM WindowSize -> IO WindowSize
forall a b. (a -> b) -> a -> b
$ do
WindowSize
w0 <- TVar WindowSize -> STM WindowSize
forall a. TVar a -> STM a
readTVar TVar WindowSize
tvar
let w1 :: WindowSize
w1 = WindowSize
w0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
n
TVar WindowSize -> WindowSize -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar WindowSize
tvar WindowSize
w1
WindowSize -> STM WindowSize
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return WindowSize
w1
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 :: WindowSize
streamNumber :: Stream -> WindowSize
streamNumber,TVar WindowSize
streamWindow :: Stream -> TVar WindowSize
streamWindow :: TVar WindowSize
streamWindow} WindowSize
n =
WindowSize -> TVar WindowSize -> WindowSize -> IO ()
increaseWindowSize WindowSize
streamNumber TVar WindowSize
streamWindow WindowSize
n
increaseConnectionWindowSize :: Context -> Int -> IO ()
increaseConnectionWindowSize :: Context -> WindowSize -> IO ()
increaseConnectionWindowSize Context{TVar WindowSize
txConnectionWindow :: Context -> TVar WindowSize
txConnectionWindow :: TVar WindowSize
txConnectionWindow} WindowSize
n =
WindowSize -> TVar WindowSize -> WindowSize -> IO ()
increaseWindowSize WindowSize
0 TVar WindowSize
txConnectionWindow WindowSize
n
decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()
decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()
decreaseWindowSize Context{TVar WindowSize
txConnectionWindow :: Context -> TVar WindowSize
txConnectionWindow :: TVar WindowSize
txConnectionWindow} Stream{TVar WindowSize
streamWindow :: Stream -> TVar WindowSize
streamWindow :: TVar WindowSize
streamWindow} WindowSize
siz = 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 WindowSize -> (WindowSize -> WindowSize) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar WindowSize
txConnectionWindow (WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
subtract WindowSize
siz)
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar WindowSize -> (WindowSize -> WindowSize) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar WindowSize
streamWindow (WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
subtract WindowSize
siz)
informWindowUpdate :: Context -> Stream -> IORef Int -> Int -> IO ()
informWindowUpdate :: Context -> Stream -> IORef WindowSize -> WindowSize -> IO ()
informWindowUpdate Context
_ Stream
_ IORef WindowSize
_ WindowSize
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 WindowSize
rxConnectionInc :: IORef WindowSize
rxConnectionInc :: Context -> IORef WindowSize
rxConnectionInc} Stream{WindowSize
streamNumber :: Stream -> WindowSize
streamNumber :: WindowSize
streamNumber} IORef WindowSize
streamInc WindowSize
len = do
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef WindowSize
-> (WindowSize -> (WindowSize, IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef WindowSize
rxConnectionInc ((WindowSize -> (WindowSize, IO ())) -> IO (IO ()))
-> (WindowSize -> (WindowSize, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ WindowSize -> WindowSize -> (WindowSize, IO ())
modify WindowSize
0
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef WindowSize
-> (WindowSize -> (WindowSize, IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef WindowSize
streamInc ((WindowSize -> (WindowSize, IO ())) -> IO (IO ()))
-> (WindowSize -> (WindowSize, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ WindowSize -> WindowSize -> (WindowSize, IO ())
modify WindowSize
streamNumber
where
modify :: WindowSize -> WindowSize -> (WindowSize, IO ())
modify WindowSize
sid WindowSize
w0
| WindowSize
w1 WindowSize -> WindowSize -> Bool
forall a. Ord a => a -> a -> Bool
< WindowSize
thresh = (WindowSize
w1, () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
| Bool
otherwise = let frame :: ByteString
frame = WindowSize -> WindowSize -> ByteString
windowUpdateFrame WindowSize
sid WindowSize
w1
cframe :: Control
cframe = Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ByteString
frame]
action :: IO ()
action = TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
cframe
in (WindowSize
0, IO ()
action)
where
thresh :: WindowSize
thresh = WindowSize
defaultWindowSize
w1 :: WindowSize
w1 = WindowSize
w0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
len
properWindowSize :: WindowSize
properWindowSize :: WindowSize
properWindowSize = WindowSize
1048575
updateMySettings :: Config -> Context -> IO [ByteString]
updateMySettings :: Config -> Context -> IO [ByteString]
updateMySettings Config{WindowSize
Buffer
Manager
WindowSize -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: WindowSize
confSendAll :: ByteString -> IO ()
confReadN :: WindowSize -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> WindowSize
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> WindowSize -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
..} Context{IORef Bool
myFirstSettings :: IORef Bool
myFirstSettings :: Context -> IORef Bool
myFirstSettings,IORef (Maybe SettingsList)
myPendingAlist :: IORef (Maybe SettingsList)
myPendingAlist :: Context -> IORef (Maybe SettingsList)
myPendingAlist} = do
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
myFirstSettings Bool
True
IORef (Maybe SettingsList) -> Maybe SettingsList -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe SettingsList)
myPendingAlist (Maybe SettingsList -> IO ()) -> Maybe SettingsList -> IO ()
forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe SettingsList
forall a. a -> Maybe a
Just SettingsList
myInitialAlist
[ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
frames
where
len :: WindowSize
len = WindowSize
confBufferSize WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
frameHeaderLength
payloadLen :: WindowSize
payloadLen = WindowSize -> WindowSize -> WindowSize
forall a. Ord a => a -> a -> a
max WindowSize
defaultPayloadLength WindowSize
len
myInitialAlist :: SettingsList
myInitialAlist =
[(SettingsKey
SettingsMaxFrameSize,WindowSize
payloadLen)
,(SettingsKey
SettingsMaxConcurrentStreams,WindowSize
recommendedConcurrency)
,(SettingsKey
SettingsInitialWindowSize,WindowSize
properWindowSize)]
frame1 :: ByteString
frame1 = (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame FrameFlags -> FrameFlags
forall a. a -> a
id SettingsList
myInitialAlist
frame2 :: ByteString
frame2 = WindowSize -> WindowSize -> ByteString
windowUpdateFrame WindowSize
0 (WindowSize
properWindowSize WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
defaultWindowSize)
frames :: [ByteString]
frames = [ByteString
frame1,ByteString
frame2]
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings Context{IORef Settings
peerSettings :: IORef Settings
peerSettings :: Context -> IORef Settings
peerSettings,StreamTable
streamTable :: StreamTable
streamTable :: Context -> StreamTable
streamTable} SettingsList
peerAlist = do
WindowSize
oldws <- Settings -> WindowSize
initialWindowSize (Settings -> WindowSize) -> IO Settings -> IO WindowSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
peerSettings
IORef Settings -> (Settings -> Settings) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
peerSettings ((Settings -> Settings) -> IO ())
-> (Settings -> Settings) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
peerAlist
WindowSize
newws <- Settings -> WindowSize
initialWindowSize (Settings -> WindowSize) -> IO Settings -> IO WindowSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
peerSettings
let diff :: WindowSize
diff = WindowSize
newws WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
oldws
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WindowSize
diff WindowSize -> WindowSize -> Bool
forall a. Eq a => a -> a -> Bool
/= WindowSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (WindowSize -> WindowSize) -> StreamTable -> IO ()
updateAllStreamWindow (WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
diff) StreamTable
streamTable