    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE NamedFieldPuns #-}

    module Network.HTTP2.H2.Window where

    import Control.Concurrent.STM
    import qualified Control.Exception as E
    import qualified Data.ByteString as BS
    import Data.IORef
    import Network.Control

    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 a. TVar a -> IO 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 a. TVar a -> IO 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 a. STM a -> IO a
    atomically (STM () -> IO ()) -> STM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
        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
        check (w > 0)

    waitConnectionWindowSize :: Context -> STM ()
    waitConnectionWindowSize :: Context -> STM ()
    waitConnectionWindowSize Context{TVar TxFlow
    txFlow :: Context -> TVar TxFlow
    txFlow :: TVar TxFlow
    txFlow} = do
        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
        check (w > 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 a. STM a -> IO 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}
        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 a. TVar a -> IO a
    readTVarIO TVar TxFlow
    tvar
        when (isWindowOverflow w) $ do
            let 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 =
                    if Int -> Bool
    isControl Int
    sid
                        then ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
    ConnectionErrorIsSent
                        else ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
    StreamErrorIsSent
            E.throwIO $ err FlowControlError sid 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 ()
    dec TVar TxFlow
    txFlow
        TVar TxFlow -> IO ()
    dec TVar TxFlow
    streamTxFlow
      where
        dec :: TVar TxFlow -> IO ()
    dec TVar TxFlow
    tvar = STM () -> IO ()
    forall a. STM a -> IO 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{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
        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
        forM_ mxc $ \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
        mxs <- atomicModifyIORef streamRxFlow $ maybeOpenRxWindow len FCTWindowUpdate
        forM_ mxs $ \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

    -- This must be called after an application is finished
    -- to adjust RX window.
    adjustRxWindow :: Context -> Stream -> IO ()
    adjustRxWindow :: Context -> Stream -> IO ()
    adjustRxWindow Context
    ctx stream :: Stream
    stream@Stream{IORef (Maybe RxQ)
    streamRxQ :: IORef (Maybe RxQ)
    streamRxQ :: Stream -> IORef (Maybe RxQ)
    streamRxQ} = do
        mq <- IORef (Maybe RxQ) -> IO (Maybe RxQ)
    forall a. IORef a -> IO a
    readIORef IORef (Maybe RxQ)
    streamRxQ
        case mq of
            Maybe RxQ
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            Just RxQ
    q -> do
                len <- RxQ -> IO Int
    forall {a} {b}. TQueue (Either a (ByteString, b)) -> IO Int
    readQ RxQ
    q
                informWindowUpdate ctx stream len
      where
        readQ :: TQueue (Either a (ByteString, b)) -> IO Int
    readQ TQueue (Either a (ByteString, b))
    q = STM Int -> IO Int
    forall a. STM a -> IO a
    atomically (STM Int -> IO Int) -> STM Int -> IO Int
    forall a b. (a -> b) -> a -> b
    $ Int -> STM Int
    loop Int
    0
          where
            loop :: Int -> STM Int
    loop !Int
    total = do
                meb <- TQueue (Either a (ByteString, b))
    -> STM (Maybe (Either a (ByteString, b)))
    forall a. TQueue a -> STM (Maybe a)
    tryReadTQueue TQueue (Either a (ByteString, b))
    q
                case meb of
                    Just (Right (ByteString
    bs, b
    _)) -> Int -> STM Int
    loop (Int
    total Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + ByteString -> Int
    BS.length ByteString
    bs)
                    Just le :: Either a (ByteString, b)
    le@(Left a
    _) -> do
                        -- reserving HTTP2Error
                        TQueue (Either a (ByteString, b))
    -> Either a (ByteString, b) -> STM ()
    forall a. TQueue a -> a -> STM ()
    writeTQueue TQueue (Either a (ByteString, b))
    q Either a (ByteString, b)
    le
                        Int -> STM Int
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    total
                    Maybe (Either a (ByteString, b))
    _ -> Int -> STM Int
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    total