{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.HTTP2.H2.Sender (
    frameSender,
) where

import Control.Concurrent.STM
import qualified Control.Exception as E
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.IntMap.Strict (IntMap)
import Foreign.Ptr (minusPtr, plusPtr)
import Network.ByteOrder
import Network.HTTP.Semantics.Client
import Network.HTTP.Semantics.IO
import System.ThreadManager

import Imports
import Network.HPACK (setLimitForEncoding, toTokenHeaderTable)
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.EncodeFrame
import Network.HTTP2.H2.HPACK
import Network.HTTP2.H2.Queue
import Network.HTTP2.H2.Settings
import Network.HTTP2.H2.Stream
import Network.HTTP2.H2.StreamTable
import Network.HTTP2.H2.Types
import Network.HTTP2.H2.Window

----------------------------------------------------------------

data Switch
    = C Control
    | O Output
    | Flush

-- Peer SETTINGS_INITIAL_WINDOW_SIZE
-- Adjusting initial window size for streams
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings Context{IORef Settings
peerSettings :: IORef Settings
peerSettings :: Context -> IORef Settings
peerSettings, TVar OddStreamTable
oddStreamTable :: TVar OddStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
oddStreamTable, TVar EvenStreamTable
evenStreamTable :: TVar EvenStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
evenStreamTable} SettingsList
peerAlist = do
    Int
oldws <- Settings -> Int
initialWindowSize (Settings -> Int) -> IO Settings -> IO Int
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
fromSettingsList Settings
old SettingsList
peerAlist
    Int
newws <- Settings -> Int
initialWindowSize (Settings -> Int) -> IO Settings -> IO Int
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
    -- FIXME: race condition
    -- 1) newOddStream reads old peerSettings and
    --    insert it to its stream table after adjusting.
    -- 2) newOddStream reads new peerSettings and
    --    insert it to its stream table before adjusting.
    let dif :: Int
dif = Int
newws Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldws
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dif Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TVar OddStreamTable -> IO (IntMap Stream)
getOddStreams TVar OddStreamTable
oddStreamTable IO (IntMap Stream) -> (IntMap Stream -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IntMap Stream -> IO ()
updateAllStreamTxFlow Int
dif
        TVar EvenStreamTable -> IO (IntMap Stream)
getEvenStreams TVar EvenStreamTable
evenStreamTable IO (IntMap Stream) -> (IntMap Stream -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IntMap Stream -> IO ()
updateAllStreamTxFlow Int
dif
  where
    updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO ()
    updateAllStreamTxFlow :: Int -> IntMap Stream -> IO ()
updateAllStreamTxFlow Int
siz IntMap Stream
strms =
        IntMap Stream -> (Stream -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ IntMap Stream
strms ((Stream -> IO ()) -> IO ()) -> (Stream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Stream
strm -> Stream -> Int -> IO ()
increaseStreamWindowSize Stream
strm Int
siz

checkDone :: Context -> Int -> IO Bool
checkDone :: Context -> Int -> IO Bool
checkDone Context{TVar Bool
TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Control
TQueue Output
ThreadManager
DynamicTable
Settings
RoleInfo
Role
peerSettings :: Context -> IORef Settings
oddStreamTable :: Context -> TVar OddStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe Int)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
receiverDone :: TVar Bool
workersDone :: STM Bool
workersDone :: Context -> STM Bool
receiverDone :: Context -> TVar Bool
threadManager :: Context -> ThreadManager
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerLastStreamId :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} Int
0 = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    Bool
isEmptyC <- TQueue Control -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
    Bool
isEmptyO <- TQueue Output -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Output
outputQ
    if Bool -> Bool
not Bool
isEmptyC Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isEmptyO
        then
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else do
            Bool
gone <- ThreadManager -> STM Bool
isAllGone ThreadManager
threadManager
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gone STM ()
forall a. STM a
retry
            Bool
done <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
receiverDone
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done STM ()
forall a. STM a
retry
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkDone Context
_ Int
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

frameSender :: Context -> Config -> IO ()
frameSender :: Context -> Config -> IO ()
frameSender
    ctx :: Context
ctx@Context{TQueue Output
outputQ :: Context -> TQueue Output
outputQ :: TQueue Output
outputQ, TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ, DynamicTable
encodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: DynamicTable
encodeDynamicTable, IORef Int
outputBufferLimit :: Context -> IORef Int
outputBufferLimit :: IORef Int
outputBufferLimit}
    Config{Bool
Int
Buffer
SockAddr
Manager
Int -> IO FieldValue
PositionReadMaker
FieldValue -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: FieldValue -> IO ()
confReadN :: Int -> IO FieldValue
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confReadNTimeout :: Bool
confReadNTimeout :: Config -> Bool
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO FieldValue
confSendAll :: Config -> FieldValue -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} = do
        String -> IO ()
labelMe String
"H2 sender"
        Int -> IO ()
loop Int
0
      where
        ----------------------------------------------------------------
        loop :: Offset -> IO ()
        loop :: Int -> IO ()
loop Int
off = do
            Bool
done <- Context -> Int -> IO Bool
checkDone Context
ctx Int
off
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Switch
x <- STM Switch -> IO Switch
forall a. STM a -> IO a
atomically (STM Switch -> IO Switch) -> STM Switch -> IO Switch
forall a b. (a -> b) -> a -> b
$ Int -> STM Switch
dequeue Int
off
                case Switch
x of
                    C Control
ctl -> Int -> IO ()
flushN Int
off IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Control -> IO ()
control Control
ctl IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop Int
0
                    O Output
out -> Output -> Int -> IO Int
outputAndSync Output
out Int
off IO Int -> (Int -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Int
flushIfNecessary IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
loop
                    Switch
Flush -> Int -> IO ()
flushN Int
off IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop Int
0

        -- Flush the connection buffer to the socket, where the first 'n' bytes of
        -- the buffer are filled.
        flushN :: Offset -> IO ()
        flushN :: Int -> IO ()
flushN Int
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        flushN Int
n = Buffer -> Int -> (FieldValue -> IO ()) -> IO ()
forall a. Buffer -> Int -> (FieldValue -> IO a) -> IO a
bufferIO Buffer
confWriteBuffer Int
n FieldValue -> IO ()
confSendAll

        flushIfNecessary :: Offset -> IO Offset
        flushIfNecessary :: Int -> IO Int
flushIfNecessary Int
off = do
            Int
buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            if Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
512
                then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                else do
                    Int -> IO ()
flushN Int
off
                    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

        dequeue :: Offset -> STM Switch
        dequeue :: Int -> STM Switch
dequeue Int
off = do
            Bool
isEmptyC <- TQueue Control -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
            if Bool
isEmptyC
                then do
                    -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit
                    Context -> STM ()
waitConnectionWindowSize Context
ctx
                    Bool
isEmptyO <- TQueue Output -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Output
outputQ
                    if Bool
isEmptyO
                        then if Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then Switch -> STM Switch
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Switch
Flush else STM Switch
forall a. STM a
retry
                        else Output -> Switch
O (Output -> Switch) -> STM Output -> STM Switch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue Output -> STM Output
forall a. TQueue a -> STM a
readTQueue TQueue Output
outputQ
                else Control -> Switch
C (Control -> Switch) -> STM Control -> STM Switch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue Control -> STM Control
forall a. TQueue a -> STM a
readTQueue TQueue Control
controlQ

        ----------------------------------------------------------------
        copyAll :: [FieldValue] -> Buffer -> IO Buffer
copyAll [] Buffer
buf = Buffer -> IO Buffer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buf
        copyAll (FieldValue
x : [FieldValue]
xs) Buffer
buf = Buffer -> FieldValue -> IO Buffer
copy Buffer
buf FieldValue
x IO Buffer -> (Buffer -> IO Buffer) -> IO Buffer
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FieldValue] -> Buffer -> IO Buffer
copyAll [FieldValue]
xs

        -- called with off == 0
        control :: Control -> IO ()
        control :: Control -> IO ()
control (CFrames Maybe SettingsList
ms [FieldValue]
xs) = do
            Buffer
buf <- [FieldValue] -> Buffer -> IO Buffer
copyAll [FieldValue]
xs Buffer
confWriteBuffer
            let off :: Int
off = Buffer
buf Buffer -> Buffer -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
confWriteBuffer
            Int -> IO ()
flushN Int
off
            case Maybe SettingsList
ms of
                Maybe SettingsList
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just SettingsList
peerAlist -> do
                    -- Peer SETTINGS_INITIAL_WINDOW_SIZE
                    Context -> SettingsList -> IO ()
updatePeerSettings Context
ctx SettingsList
peerAlist
                    -- Peer SETTINGS_MAX_FRAME_SIZE
                    case SettingsKey -> SettingsList -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsMaxFrameSize SettingsList
peerAlist of
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Int
payloadLen -> do
                            let dlim :: Int
dlim = Int
payloadLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                                buflim :: Int
buflim
                                    | Int
confBufferSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
dlim = Int
dlim
                                    | Bool
otherwise = Int
confBufferSize
                            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
outputBufferLimit Int
buflim
                    -- Peer SETTINGS_HEADER_TABLE_SIZE
                    case SettingsKey -> SettingsList -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsTokenHeaderTableSize SettingsList
peerAlist of
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Int
siz -> Int -> DynamicTable -> IO ()
setLimitForEncoding Int
siz DynamicTable
encodeDynamicTable

        ----------------------------------------------------------------
        -- INVARIANT
        --
        -- Both the stream window and the connection window are open.
        ----------------------------------------------------------------
        outputAndSync :: Output -> Offset -> IO Offset
        outputAndSync :: Output -> Int -> IO Int
outputAndSync out :: Output
out@(Output Stream
strm OutputType
otyp Maybe Output -> IO ()
sync) Int
off = (SomeException -> IO Int) -> IO Int -> IO Int
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\SomeException
e -> Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
InternalError SomeException
e IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
            StreamState
state <- Stream -> IO StreamState
readStreamState Stream
strm
            if StreamState -> Bool
isHalfClosedLocal StreamState
state
                then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                else case OutputType
otyp of
                    OHeader [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr -> do
                        (Int
off', Maybe Output
mout') <- Stream
-> [Header]
-> Maybe DynaNext
-> TrailersMaker
-> (Maybe Output -> IO ())
-> Int
-> IO (Int, Maybe Output)
outputHeader Stream
strm [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr Maybe Output -> IO ()
sync Int
off
                        Maybe Output -> IO ()
sync Maybe Output
mout'
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off'
                    OutputType
_ -> do
                        Int
sws <- Stream -> IO Int
getStreamWindowSize Stream
strm
                        Int
cws <- Context -> IO Int
getConnectionWindowSize Context
ctx -- not 0
                        let lim :: Int
lim = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
cws Int
sws
                        (Int
off', Maybe Output
mout') <- Output -> Int -> Int -> IO (Int, Maybe Output)
output Output
out Int
off Int
lim
                        Maybe Output -> IO ()
sync Maybe Output
mout'
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off'

        resetStream :: Stream -> ErrorCode -> E.SomeException -> IO ()
        resetStream :: Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
err SomeException
e
            | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
e = SomeException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
            | Bool
otherwise = do
                Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm (SomeException -> ClosedCode
ResetByMe SomeException
e)
                let rst :: FieldValue
rst = ErrorCode -> Int -> FieldValue
resetFrame ErrorCode
err (Int -> FieldValue) -> Int -> FieldValue
forall a b. (a -> b) -> a -> b
$ Stream -> Int
streamNumber Stream
strm
                TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [FieldValue] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [FieldValue
rst]

        ----------------------------------------------------------------
        outputHeader
            :: Stream
            -> [Header]
            -> Maybe DynaNext
            -> TrailersMaker
            -> (Maybe Output -> IO ())
            -> Offset
            -> IO (Offset, Maybe Output)
        outputHeader :: Stream
-> [Header]
-> Maybe DynaNext
-> TrailersMaker
-> (Maybe Output -> IO ())
-> Int
-> IO (Int, Maybe Output)
outputHeader Stream
strm [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr Maybe Output -> IO ()
sync Int
off0 = do
            -- Header frame and Continuation frame
            let sid :: Int
sid = Stream -> Int
streamNumber Stream
strm
                endOfStream :: Bool
endOfStream = Maybe DynaNext -> Bool
forall a. Maybe a -> Bool
isNothing Maybe DynaNext
mnext
            (TokenHeaderList
ths, ValueTable
_) <- [Header] -> IO (TokenHeaderList, ValueTable)
toTokenHeaderTable ([Header] -> IO (TokenHeaderList, ValueTable))
-> [Header] -> IO (TokenHeaderList, ValueTable)
forall a b. (a -> b) -> a -> b
$ [Header] -> [Header]
fixHeaders [Header]
hdr
            Int
off' <- Int -> TokenHeaderList -> Bool -> Int -> IO Int
headerContinue Int
sid TokenHeaderList
ths Bool
endOfStream Int
off0
            -- halfClosedLocal calls closed which removes
            -- the stream from stream table.
            Int
off <- Int -> IO Int
flushIfNecessary Int
off'
            case Maybe DynaNext
mnext of
                Maybe DynaNext
Nothing -> do
                    -- endOfStream
                    Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
                    (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off, Maybe Output
forall a. Maybe a
Nothing)
                Just DynaNext
next -> do
                    let out' :: Output
out' = Stream -> OutputType -> (Maybe Output -> IO ()) -> Output
Output Stream
strm (DynaNext -> TrailersMaker -> OutputType
ONext DynaNext
next TrailersMaker
tlrmkr) Maybe Output -> IO ()
sync
                    (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off, Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out')

        ----------------------------------------------------------------
        output :: Output -> Offset -> WindowSize -> IO (Offset, Maybe Output)
        output :: Output -> Int -> Int -> IO (Int, Maybe Output)
output out :: Output
out@(Output Stream
strm (ONext DynaNext
curr TrailersMaker
tlrmkr) Maybe Output -> IO ()
_) Int
off0 Int
lim = do
            -- Data frame payload
            Int
buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let payloadOff :: Int
payloadOff = Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                datBuf :: Ptr b
datBuf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
payloadOff
                datBufSiz :: Int
datBufSiz = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
payloadOff
            DynaNext
curr Buffer
forall {b}. Ptr b
datBuf (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
datBufSiz Int
lim) IO Next
-> (Next -> IO (Int, Maybe Output)) -> IO (Int, Maybe Output)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Next Int
datPayloadLen Bool
reqflush Maybe DynaNext
mnext -> do
                    NextTrailersMaker TrailersMaker
tlrmkr' <- TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
forall {b}. Ptr b
datBuf Int
datPayloadLen
                    Stream
-> Int
-> Int
-> Maybe DynaNext
-> TrailersMaker
-> Output
-> Bool
-> IO (Int, Maybe Output)
fillDataHeader
                        Stream
strm
                        Int
off0
                        Int
datPayloadLen
                        Maybe DynaNext
mnext
                        TrailersMaker
tlrmkr'
                        Output
out
                        Bool
reqflush
                CancelNext Maybe SomeException
mErr -> do
                    -- Stream cancelled
                    --
                    -- At this point, the headers have already been sent.
                    -- Therefore, the stream cannot be in the 'Idle' state, so we
                    -- are justified in sending @RST_STREAM@.
                    --
                    -- By the invariant on the 'outputQ', there are no other
                    -- outputs for this stream already enqueued. Therefore, we can
                    -- safely cancel it knowing that we won't try and send any
                    -- more data frames on this stream.
                    case Maybe SomeException
mErr of
                        Just SomeException
err ->
                            Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
InternalError SomeException
err
                        Maybe SomeException
Nothing ->
                            Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
Cancel (CancelledStream -> SomeException
forall e. Exception e => e -> SomeException
E.toException CancelledStream
CancelledStream)
                    (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off0, Maybe Output
forall a. Maybe a
Nothing)
        output (Output Stream
strm (OPush TokenHeaderList
ths Int
pid) Maybe Output -> IO ()
_) Int
off0 Int
_lim = do
            -- Creating a push promise header
            -- Frame id should be associated stream id from the client.
            let sid :: Int
sid = Stream -> Int
streamNumber Stream
strm
            Int
len <- Int -> Int -> TokenHeaderList -> Int -> IO Int
pushPromise Int
pid Int
sid TokenHeaderList
ths Int
off0
            Int
off <- Int -> IO Int
flushIfNecessary (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
            (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off, Maybe Output
forall a. Maybe a
Nothing)
        output Output
_ Int
_ Int
_ = IO (Int, Maybe Output)
forall a. HasCallStack => a
undefined -- never reached

        ----------------------------------------------------------------
        headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset
        headerContinue :: Int -> TokenHeaderList -> Bool -> Int -> IO Int
headerContinue Int
sid TokenHeaderList
ths0 Bool
endOfStream Int
off0 = do
            Int
buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let offkv :: Int
offkv = Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv :: Int
limkv = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offkv
            (TokenHeaderList
ths, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths0
            if Int
kvlen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                then Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off0 TokenHeaderList
ths FrameType
FrameHeaders
                else do
                    let flag :: FrameFlags
flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths
                        buf :: Ptr b
buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off0
                        off :: Int
off = Int
offkv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kvlen
                    FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameHeaders Int
kvlen Int
sid FrameFlags
flag Buffer
forall {b}. Ptr b
buf
                    Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off TokenHeaderList
ths FrameType
FrameContinuation
          where
            eos :: FrameFlags -> FrameFlags
eos = if Bool
endOfStream then FrameFlags -> FrameFlags
setEndStream else FrameFlags -> FrameFlags
forall a. a -> a
id
            getFlag :: [a] -> FrameFlags
getFlag [] = FrameFlags -> FrameFlags
eos (FrameFlags -> FrameFlags) -> FrameFlags -> FrameFlags
forall a b. (a -> b) -> a -> b
$ FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags
            getFlag [a]
_ = FrameFlags -> FrameFlags
eos FrameFlags
defaultFlags

            continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset
            continue :: Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off [] FrameType
_ = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
            continue Int
off TokenHeaderList
ths FrameType
ft = do
                Int -> IO ()
flushN Int
off
                -- Now off is 0
                Int
buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
                let bufHeaderPayload :: Ptr b
bufHeaderPayload = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
frameHeaderLength

                    headerPayloadLim :: Int
headerPayloadLim = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frameHeaderLength
                (TokenHeaderList
ths', Int
kvlen') <-
                    Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeaderLoop Context
ctx Buffer
forall {b}. Ptr b
bufHeaderPayload Int
headerPayloadLim TokenHeaderList
ths
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TokenHeaderList
ths TokenHeaderList -> TokenHeaderList -> Bool
forall a. Eq a => a -> a -> Bool
== TokenHeaderList
ths') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
CompressionError Int
sid ReasonPhrase
"cannot compress the header"
                let flag :: FrameFlags
flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths'
                    off' :: Int
off' = Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kvlen'
                FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
ft Int
kvlen' Int
sid FrameFlags
flag Buffer
confWriteBuffer
                Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off' TokenHeaderList
ths' FrameType
FrameContinuation

        ----------------------------------------------------------------
        fillDataHeader
            :: Stream
            -> Offset
            -> Int
            -> Maybe DynaNext
            -> (Maybe ByteString -> IO NextTrailersMaker)
            -> Output
            -> Bool
            -> IO (Offset, Maybe Output)
        fillDataHeader :: Stream
-> Int
-> Int
-> Maybe DynaNext
-> TrailersMaker
-> Output
-> Bool
-> IO (Int, Maybe Output)
fillDataHeader
            strm :: Stream
strm@Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber}
            Int
off
            Int
datPayloadLen
            Maybe DynaNext
Nothing
            TrailersMaker
tlrmkr
            Output
_
            Bool
reqflush = do
                let buf :: Ptr b
buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                (Maybe [Header]
mtrailers, FrameFlags
flag) <- do
                    Trailers [Header]
trailers <- TrailersMaker
tlrmkr Maybe FieldValue
forall a. Maybe a
Nothing
                    if [Header] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Header]
trailers
                        then (Maybe [Header], FrameFlags) -> IO (Maybe [Header], FrameFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Header]
forall a. Maybe a
Nothing, FrameFlags -> FrameFlags
setEndStream FrameFlags
defaultFlags)
                        else (Maybe [Header], FrameFlags) -> IO (Maybe [Header], FrameFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header] -> Maybe [Header]
forall a. a -> Maybe a
Just [Header]
trailers, FrameFlags
defaultFlags)
                -- Avoid sending an empty data frame before trailers at the end
                -- of a stream
                Int
off' <-
                    if Int
datPayloadLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| Maybe [Header] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [Header]
mtrailers
                        then do
                            Context -> Stream -> Int -> IO ()
decreaseWindowSize Context
ctx Stream
strm Int
datPayloadLen
                            FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameData Int
datPayloadLen Int
streamNumber FrameFlags
flag Buffer
forall {b}. Ptr b
buf
                            Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
datPayloadLen
                        else
                            Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                Int
off'' <- Maybe [Header] -> Int -> IO Int
handleTrailers Maybe [Header]
mtrailers Int
off'
                Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
                if Bool
reqflush
                    then do
                        Int -> IO ()
flushN Int
off''
                        (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Maybe Output
forall a. Maybe a
Nothing)
                    else (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off'', Maybe Output
forall a. Maybe a
Nothing)
              where
                handleTrailers :: Maybe [Header] -> Int -> IO Int
handleTrailers Maybe [Header]
Nothing Int
off0 = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off0
                handleTrailers (Just [Header]
trailers) Int
off0 = do
                    (TokenHeaderList
ths, ValueTable
_) <- [Header] -> IO (TokenHeaderList, ValueTable)
toTokenHeaderTable [Header]
trailers
                    Int -> TokenHeaderList -> Bool -> Int -> IO Int
headerContinue Int
streamNumber TokenHeaderList
ths Bool
True {- endOfStream -} Int
off0
        fillDataHeader
            Stream
_
            Int
off
            Int
0
            (Just DynaNext
next)
            TrailersMaker
tlrmkr
            Output
out
            Bool
reqflush = do
                let out' :: Output
out' = Output
out{outputType = ONext next tlrmkr}
                if Bool
reqflush
                    then do
                        Int -> IO ()
flushN Int
off
                        (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out')
                    else (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off, Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out')
        fillDataHeader
            strm :: Stream
strm@Stream{Int
streamNumber :: Stream -> Int
streamNumber :: Int
streamNumber}
            Int
off
            Int
datPayloadLen
            (Just DynaNext
next)
            TrailersMaker
tlrmkr
            Output
out
            Bool
reqflush = do
                let buf :: Ptr b
buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                    off' :: Int
off' = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
datPayloadLen
                    flag :: FrameFlags
flag = FrameFlags
defaultFlags
                FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameData Int
datPayloadLen Int
streamNumber FrameFlags
flag Buffer
forall {b}. Ptr b
buf
                Context -> Stream -> Int -> IO ()
decreaseWindowSize Context
ctx Stream
strm Int
datPayloadLen
                let out' :: Output
out' = Output
out{outputType = ONext next tlrmkr}
                if Bool
reqflush
                    then do
                        Int -> IO ()
flushN Int
off'
                        (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out')
                    else (Int, Maybe Output) -> IO (Int, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off', Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out')

        ----------------------------------------------------------------
        pushPromise :: StreamId -> StreamId -> TokenHeaderList -> Offset -> IO Int
        pushPromise :: Int -> Int -> TokenHeaderList -> Int -> IO Int
pushPromise Int
pid Int
sid TokenHeaderList
ths Int
off = do
            let offsid :: Int
offsid = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength -- checkme
                bufsid :: Ptr b
bufsid = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offsid
            Word32 -> Buffer -> Int -> IO ()
poke32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sid) Buffer
forall {b}. Ptr b
bufsid Int
0
            let offkv :: Int
offkv = Int
offsid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv :: Int
limkv = Int
confBufferSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offkv
            (TokenHeaderList
_, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths
            let flag :: FrameFlags
flag = FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags -- No EndStream flag
                buf :: Ptr b
buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                len :: Int
len = Int
kvlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
            FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FramePushPromise Int
len Int
pid FrameFlags
flag Buffer
forall {b}. Ptr b
buf
            Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
len

        ----------------------------------------------------------------
        {-# INLINE fillFrameHeader #-}
        fillFrameHeader :: FrameType -> Int -> StreamId -> FrameFlags -> Buffer -> IO ()
        fillFrameHeader :: FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
ftyp Int
len Int
sid FrameFlags
flag Buffer
buf = FrameType -> FrameHeader -> Buffer -> IO ()
encodeFrameHeaderBuf FrameType
ftyp FrameHeader
hinfo Buffer
buf
          where
            hinfo :: FrameHeader
hinfo =
                FrameHeader
                    { payloadLength :: Int
payloadLength = Int
len
                    , flags :: FrameFlags
flags = FrameFlags
flag
                    , streamId :: Int
streamId = Int
sid
                    }