{-# 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
    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
    modifyIORef' peerSettings $ \Settings
old -> Settings -> SettingsList -> Settings
fromSettingsList Settings
old SettingsList
peerAlist
    newws <- initialWindowSize <$> readIORef 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
newws Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldws
    when (dif /= 0) $ do
        getOddStreams oddStreamTable >>= updateAllStreamTxFlow dif
        getEvenStreams evenStreamTable >>= updateAllStreamTxFlow 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
    isEmptyC <- TQueue Control -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
    isEmptyO <- isEmptyTQueue outputQ
    if not isEmptyC || not isEmptyO
        then
            return False
        else do
            gone <- isAllGone threadManager
            unless gone retry
            done <- readTVar receiverDone
            unless done retry
            return 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
            done <- Context -> Int -> IO Bool
checkDone Context
ctx Int
off
            unless done $ do
                x <- atomically $ dequeue off
                case 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
            buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            if off <= buflim - 512
                then return off
                else do
                    flushN off
                    return 0

        dequeue :: Offset -> STM Switch
        dequeue :: Int -> STM Switch
dequeue Int
off = do
            isEmptyC <- TQueue Control -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
            if isEmptyC
                then do
                    -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit
                    waitConnectionWindowSize ctx
                    isEmptyO <- isEmptyTQueue outputQ
                    if isEmptyO
                        then if off /= 0 then return Flush else retry
                        else O <$> readTQueue outputQ
                else C <$> readTQueue 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
            buf <- [FieldValue] -> Buffer -> IO Buffer
copyAll [FieldValue]
xs Buffer
confWriteBuffer
            let off = Buffer
buf Buffer -> Buffer -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
confWriteBuffer
            flushN off
            case 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
            state <- Stream -> IO StreamState
readStreamState Stream
strm
            if isHalfClosedLocal state
                then return off
                else case otyp of
                    OHeader [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr -> do
                        (off', 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
                        sync mout'
                        return off'
                    OutputType
_ -> do
                        sws <- Stream -> IO Int
getStreamWindowSize Stream
strm
                        cws <- getConnectionWindowSize ctx -- not 0
                        let lim = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
cws Int
sws
                        (off', mout') <- output out off lim
                        sync mout'
                        return 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. (HasCallStack, 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
            (ths, _) <- [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
            off' <- headerContinue sid ths endOfStream off0
            -- halfClosedLocal calls closed which removes
            -- the stream from stream table.
            off <- flushIfNecessary off'
            case 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
            buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let payloadOff = Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                datBuf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
payloadOff
                datBufSiz = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
payloadOff
            curr datBuf (min datBufSiz lim) >>= \case
                Next Int
datPayloadLen Bool
reqflush Maybe DynaNext
mnext -> do
                    NextTrailersMaker tlrmkr' <- TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
forall {b}. Ptr b
datBuf Int
datPayloadLen
                    fillDataHeader
                        strm
                        off0
                        datPayloadLen
                        mnext
                        tlrmkr'
                        out
                        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
            len <- Int -> Int -> TokenHeaderList -> Int -> IO Int
pushPromise Int
pid Int
sid TokenHeaderList
ths Int
off0
            off <- flushIfNecessary $ off0 + frameHeaderLength + len
            return (off, 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
            buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let offkv = Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                bufkv = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offkv
            (ths, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0
            if kvlen == 0
                then continue off0 ths FrameHeaders
                else do
                    let flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths
                        buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off0
                        off = Int
offkv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kvlen
                    fillFrameHeader FrameHeaders kvlen sid flag buf
                    continue off ths 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
                buflim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
                let bufHeaderPayload = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
frameHeaderLength

                    headerPayloadLim = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frameHeaderLength
                (ths', kvlen') <-
                    hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths
                when (ths == ths') $
                    E.throwIO $
                        ConnectionErrorIsSent CompressionError sid "cannot compress the header"
                let flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths'
                    off' = Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kvlen'
                fillFrameHeader ft kvlen' sid flag confWriteBuffer
                continue off' ths' 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
                (mtrailers, flag) <- do
                    Trailers trailers <- TrailersMaker
tlrmkr Maybe FieldValue
forall a. Maybe a
Nothing
                    if null trailers
                        then return (Nothing, setEndStream defaultFlags)
                        else return (Just trailers, defaultFlags)
                -- Avoid sending an empty data frame before trailers at the end
                -- of a stream
                off' <-
                    if datPayloadLen /= 0 || isNothing mtrailers
                        then do
                            decreaseWindowSize ctx strm datPayloadLen
                            fillFrameHeader FrameData datPayloadLen streamNumber flag buf
                            return $ off + frameHeaderLength + datPayloadLen
                        else
                            return off
                off'' <- handleTrailers mtrailers off'
                halfClosedLocal ctx strm Finished
                if reqflush
                    then do
                        flushN off''
                        return (0, Nothing)
                    else return (off'', 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
                    (ths, _) <- [Header] -> IO (TokenHeaderList, ValueTable)
toTokenHeaderTable [Header]
trailers
                    headerContinue streamNumber ths True {- endOfStream -} 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
            (_, kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths
            let flag = FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags -- No EndStream flag
                buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                len = Int
kvlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
            fillFrameHeader FramePushPromise len pid flag buf
            return 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
                    }