{-# 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 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

wrapException :: E.SomeException -> IO ()
wrapException :: SomeException -> IO ()
wrapException SomeException
se
    | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
se = SomeException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO SomeException
se
    | Just HTTP2Error
GoAwayIsSent <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Just HTTP2Error
ConnectionIsClosed <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Just (HTTP2Error
e :: HTTP2Error) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
    | Bool
otherwise = HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> HTTP2Error
BadThingHappen SomeException
se

-- 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
    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
fromSettingsList 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
    -- 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 :: WindowSize
dif = 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
dif WindowSize -> WindowSize -> Bool
forall a. Eq a => a -> a -> Bool
/= WindowSize
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
>>= WindowSize -> IntMap Stream -> IO ()
updateAllStreamTxFlow WindowSize
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
>>= WindowSize -> IntMap Stream -> IO ()
updateAllStreamTxFlow WindowSize
dif
  where
    updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO ()
    updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO ()
updateAllStreamTxFlow WindowSize
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 -> WindowSize -> IO ()
increaseStreamWindowSize Stream
strm WindowSize
siz

frameSender :: Context -> Config -> IO ()
frameSender :: Context -> Config -> IO ()
frameSender
    ctx :: Context
ctx@Context{TQueue Output
outputQ :: TQueue Output
outputQ :: Context -> TQueue Output
outputQ, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, DynamicTable
encodeDynamicTable :: DynamicTable
encodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable, IORef WindowSize
outputBufferLimit :: IORef WindowSize
outputBufferLimit :: Context -> IORef WindowSize
outputBufferLimit, TVar Bool
senderDone :: TVar Bool
senderDone :: Context -> TVar Bool
senderDone}
    Config{WindowSize
Buffer
Manager
SockAddr
WindowSize -> IO FieldValue
PositionReadMaker
FieldValue -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: WindowSize
confSendAll :: FieldValue -> IO ()
confReadN :: WindowSize -> IO FieldValue
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> WindowSize
confSendAll :: Config -> FieldValue -> IO ()
confReadN :: Config -> WindowSize -> IO FieldValue
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
..} = do
        String -> IO ()
labelMe String
"H2 sender"
        (WindowSize -> IO ()
loop WindowSize
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
setSenderDone) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
wrapException
      where
        ----------------------------------------------------------------
        loop :: Offset -> IO ()
        loop :: WindowSize -> IO ()
loop WindowSize
off = 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
$ WindowSize -> STM Switch
dequeue WindowSize
off
            case Switch
x of
                C Control
ctl -> WindowSize -> IO ()
flushN WindowSize
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
>> WindowSize -> IO ()
loop WindowSize
0
                O Output
out -> Output -> WindowSize -> IO WindowSize
outputAndSync Output
out WindowSize
off IO WindowSize -> (WindowSize -> IO WindowSize) -> IO WindowSize
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WindowSize -> IO WindowSize
flushIfNecessary IO WindowSize -> (WindowSize -> 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
>>= WindowSize -> IO ()
loop
                Switch
Flush -> WindowSize -> IO ()
flushN WindowSize
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
>> WindowSize -> IO ()
loop WindowSize
0

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

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

        dequeue :: Offset -> STM Switch
        dequeue :: WindowSize -> STM Switch
dequeue WindowSize
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 WindowSize
off WindowSize -> WindowSize -> Bool
forall a. Eq a => a -> a -> Bool
/= WindowSize
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 (CFinish HTTP2Error
e) = HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e
        control (CFrames Maybe SettingsList
ms [FieldValue]
xs) = do
            Buffer
buf <- [FieldValue] -> Buffer -> IO Buffer
copyAll [FieldValue]
xs Buffer
confWriteBuffer
            let off :: WindowSize
off = Buffer
buf Buffer -> Buffer -> WindowSize
forall a b. Ptr a -> Ptr b -> WindowSize
`minusPtr` Buffer
confWriteBuffer
            WindowSize -> IO ()
flushN WindowSize
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 WindowSize
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsMaxFrameSize SettingsList
peerAlist of
                        Maybe WindowSize
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just WindowSize
payloadLen -> do
                            let dlim :: WindowSize
dlim = WindowSize
payloadLen WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
frameHeaderLength
                                buflim :: WindowSize
buflim
                                    | WindowSize
confBufferSize WindowSize -> WindowSize -> Bool
forall a. Ord a => a -> a -> Bool
>= WindowSize
dlim = WindowSize
dlim
                                    | Bool
otherwise = WindowSize
confBufferSize
                            IORef WindowSize -> WindowSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WindowSize
outputBufferLimit WindowSize
buflim
                    -- Peer SETTINGS_HEADER_TABLE_SIZE
                    case SettingsKey -> SettingsList -> Maybe WindowSize
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsTokenHeaderTableSize SettingsList
peerAlist of
                        Maybe WindowSize
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just WindowSize
siz -> WindowSize -> DynamicTable -> IO ()
setLimitForEncoding WindowSize
siz DynamicTable
encodeDynamicTable

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

        resetStream :: Stream -> ErrorCode -> E.SomeException -> IO ()
        resetStream :: Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
err SomeException
e = do
            Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm (SomeException -> ClosedCode
ResetByMe SomeException
e)
            let rst :: FieldValue
rst = ErrorCode -> WindowSize -> FieldValue
resetFrame ErrorCode
err (WindowSize -> FieldValue) -> WindowSize -> FieldValue
forall a b. (a -> b) -> a -> b
$ Stream -> WindowSize
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 ())
-> WindowSize
-> IO (WindowSize, Maybe Output)
outputHeader Stream
strm [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr Maybe Output -> IO ()
sync WindowSize
off0 = do
            -- Header frame and Continuation frame
            let sid :: WindowSize
sid = Stream -> WindowSize
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
            WindowSize
off' <- WindowSize
-> TokenHeaderList -> Bool -> WindowSize -> IO WindowSize
headerContinue WindowSize
sid TokenHeaderList
ths Bool
endOfStream WindowSize
off0
            -- halfClosedLocal calls closed which removes
            -- the stream from stream table.
            WindowSize
off <- WindowSize -> IO WindowSize
flushIfNecessary WindowSize
off'
            case Maybe DynaNext
mnext of
                Maybe DynaNext
Nothing -> do
                    -- endOfStream
                    Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
                    (WindowSize, Maybe Output) -> IO (WindowSize, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowSize
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
                    (WindowSize, Maybe Output) -> IO (WindowSize, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowSize
off, Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out')

        ----------------------------------------------------------------
        output :: Output -> Offset -> WindowSize -> IO (Offset, Maybe Output)
        output :: Output -> WindowSize -> WindowSize -> IO (WindowSize, Maybe Output)
output out :: Output
out@(Output Stream
strm (ONext DynaNext
curr TrailersMaker
tlrmkr) Maybe Output -> IO ()
_) WindowSize
off0 WindowSize
lim = do
            -- Data frame payload
            WindowSize
buflim <- IORef WindowSize -> IO WindowSize
forall a. IORef a -> IO a
readIORef IORef WindowSize
outputBufferLimit
            let payloadOff :: WindowSize
payloadOff = WindowSize
off0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
frameHeaderLength
                datBuf :: Ptr b
datBuf = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
payloadOff
                datBufSiz :: WindowSize
datBufSiz = WindowSize
buflim WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
payloadOff
            DynaNext
curr Buffer
forall {b}. Ptr b
datBuf (WindowSize -> WindowSize -> WindowSize
forall a. Ord a => a -> a -> a
min WindowSize
datBufSiz WindowSize
lim) IO Next
-> (Next -> IO (WindowSize, Maybe Output))
-> IO (WindowSize, 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
>>= \Next
next ->
                case Next
next of
                    Next WindowSize
datPayloadLen Bool
reqflush Maybe DynaNext
mnext -> do
                        NextTrailersMaker TrailersMaker
tlrmkr' <- TrailersMaker -> Buffer -> WindowSize -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
forall {b}. Ptr b
datBuf WindowSize
datPayloadLen
                        Stream
-> WindowSize
-> WindowSize
-> Maybe DynaNext
-> TrailersMaker
-> Output
-> Bool
-> IO (WindowSize, Maybe Output)
fillDataHeader
                            Stream
strm
                            WindowSize
off0
                            WindowSize
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)
                        (WindowSize, Maybe Output) -> IO (WindowSize, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowSize
off0, Maybe Output
forall a. Maybe a
Nothing)
        output (Output Stream
strm (OPush TokenHeaderList
ths WindowSize
pid) Maybe Output -> IO ()
_) WindowSize
off0 WindowSize
_lim = do
            -- Creating a push promise header
            -- Frame id should be associated stream id from the client.
            let sid :: WindowSize
sid = Stream -> WindowSize
streamNumber Stream
strm
            WindowSize
len <- WindowSize
-> WindowSize -> TokenHeaderList -> WindowSize -> IO WindowSize
pushPromise WindowSize
pid WindowSize
sid TokenHeaderList
ths WindowSize
off0
            WindowSize
off <- WindowSize -> IO WindowSize
flushIfNecessary (WindowSize -> IO WindowSize) -> WindowSize -> IO WindowSize
forall a b. (a -> b) -> a -> b
$ WindowSize
off0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
frameHeaderLength WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
len
            (WindowSize, Maybe Output) -> IO (WindowSize, Maybe Output)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowSize
off, Maybe Output
forall a. Maybe a
Nothing)
        output Output
_ WindowSize
_ WindowSize
_ = IO (WindowSize, Maybe Output)
forall a. HasCallStack => a
undefined -- never reached

        ----------------------------------------------------------------
        headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset
        headerContinue :: WindowSize
-> TokenHeaderList -> Bool -> WindowSize -> IO WindowSize
headerContinue WindowSize
sid TokenHeaderList
ths0 Bool
endOfStream WindowSize
off0 = do
            WindowSize
buflim <- IORef WindowSize -> IO WindowSize
forall a. IORef a -> IO a
readIORef IORef WindowSize
outputBufferLimit
            let offkv :: WindowSize
offkv = WindowSize
off0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
frameHeaderLength
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
offkv
                limkv :: WindowSize
limkv = WindowSize
buflim WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
offkv
            (TokenHeaderList
ths, WindowSize
kvlen) <- Context
-> Buffer
-> WindowSize
-> TokenHeaderList
-> IO (TokenHeaderList, WindowSize)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv WindowSize
limkv TokenHeaderList
ths0
            if WindowSize
kvlen WindowSize -> WindowSize -> Bool
forall a. Eq a => a -> a -> Bool
== WindowSize
0
                then WindowSize -> TokenHeaderList -> FrameType -> IO WindowSize
continue WindowSize
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 -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
off0
                        off :: WindowSize
off = WindowSize
offkv WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
kvlen
                    FrameType
-> WindowSize -> WindowSize -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameHeaders WindowSize
kvlen WindowSize
sid FrameFlags
flag Buffer
forall {b}. Ptr b
buf
                    WindowSize -> TokenHeaderList -> FrameType -> IO WindowSize
continue WindowSize
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 -> FrameFlags) -> FrameFlags -> FrameFlags
forall a b. (a -> b) -> a -> b
$ FrameFlags
defaultFlags

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

                    headerPayloadLim :: WindowSize
headerPayloadLim = WindowSize
buflim WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
frameHeaderLength
                (TokenHeaderList
ths', WindowSize
kvlen') <-
                    Context
-> Buffer
-> WindowSize
-> TokenHeaderList
-> IO (TokenHeaderList, WindowSize)
hpackEncodeHeaderLoop Context
ctx Buffer
forall {b}. Ptr b
bufHeaderPayload WindowSize
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 -> WindowSize -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
CompressionError WindowSize
sid ReasonPhrase
"cannot compress the header"
                let flag :: FrameFlags
flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths'
                    off' :: WindowSize
off' = WindowSize
frameHeaderLength WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
kvlen'
                FrameType
-> WindowSize -> WindowSize -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
ft WindowSize
kvlen' WindowSize
sid FrameFlags
flag Buffer
confWriteBuffer
                WindowSize -> TokenHeaderList -> FrameType -> IO WindowSize
continue WindowSize
off' TokenHeaderList
ths' FrameType
FrameContinuation

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

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

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

        setSenderDone :: IO ()
setSenderDone = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
senderDone Bool
True