{-# 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 qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.Lazy
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.IntMap.Strict (IntMap)
import Foreign.Ptr (castPtr, minusPtr, plusPtr)
import Network.ByteOrder
import Network.HTTP.Semantics.Client
import Network.HTTP.Semantics.IO
import qualified System.ThreadManager as T

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 IO () -> (HTTP2Error -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` HTTP2Error -> IO ()
forall {a}. HTTP2Error -> IO a
connectionError
    -- RFC 9113, section 6.9.2: "An endpoint MUST treat a change to
    -- SETTINGS_INITIAL_WINDOW_SIZE that causes any flow-control window to
    -- exceed the maximum size as a connection error of type
    -- FLOW_CONTROL_ERROR."  The same overflow from a WINDOW_UPDATE is a stream
    -- error, which is what 'increaseStreamWindowSize' raises.
    connectionError :: HTTP2Error -> IO a
connectionError (StreamErrorIsSent ErrorCode
err Int
sid ReasonPhrase
msg) =
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
err Int
sid ReasonPhrase
msg
    connectionError HTTP2Error
e = HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
e

-- | Whether the sender is done: nothing left to send, and the receiver
-- done or the application done.  Otherwise it waits for something to send.
--
-- The application is done once outputs waiting for their stream windows,
-- each in a thread of its own, are gone too.  Workers are not waited for
-- when the receiver is done: they wait on streams closed only after this.
--
-- DATA parked for the connection window is something to send once the
-- window opens.  Left out, a sender with nothing else queued waited here
-- for the control or output queue, and a WINDOW_UPDATE opening the window
-- puts nothing in either: everything parked stayed parked, until some
-- other frame happened to come along -- and when none did, the connection
-- stalled.
checkDone :: Context -> TVar [Output] -> Int -> IO (Maybe E.SomeException)
checkDone :: Context -> TVar [Output] -> Int -> IO (Maybe SomeException)
checkDone ctx :: Context
ctx@Context{TVar Int
TVar (Maybe Int)
TVar (Maybe SomeException)
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe HeaderContinuation)
IORef IntSet
IORef RxFlow
IORef Settings
STM Bool
SockAddr
Rate
TQueue Output
Manager
ThreadManager
DynamicTable
Settings
ControlQ
RoleInfo
Role
Int -> TokenHeaderTable -> IO ()
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 HeaderContinuation)
myStreamId :: TVar Int
peerStreamId :: IORef Int
peerLastStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: ControlQ
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: ThreadManager
timeoutManager :: Manager
receiverDone :: TVar (Maybe SomeException)
appDone :: STM Bool
informationalCallback :: Int -> TokenHeaderTable -> IO ()
peerGoAway :: TVar (Maybe Int)
activeRequests :: TVar Int
resetByMe :: IORef IntSet
resetByMe :: Context -> IORef IntSet
activeRequests :: Context -> TVar Int
peerGoAway :: Context -> TVar (Maybe Int)
informationalCallback :: Context -> Int -> TokenHeaderTable -> IO ()
appDone :: Context -> STM Bool
receiverDone :: Context -> TVar (Maybe SomeException)
timeoutManager :: Context -> Manager
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 -> ControlQ
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 HeaderContinuation)
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} TVar [Output]
parked Int
0 = STM (Maybe SomeException) -> IO (Maybe SomeException)
forall a. STM a -> IO a
atomically (STM (Maybe SomeException) -> IO (Maybe SomeException))
-> STM (Maybe SomeException) -> IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$ do
    Bool
isEmptyC <- ControlQ -> STM Bool
isEmptyControlQ ControlQ
controlQ
    Bool
isEmptyO <- TQueue Output -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Output
outputQ
    [Output]
ps <- TVar [Output] -> STM [Output]
forall a. TVar a -> STM a
readTVar TVar [Output]
parked
    Int
cws <- Context -> STM Int
connectionWindowSizeSTM Context
ctx
    if Bool -> Bool
not Bool
isEmptyC Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isEmptyO Bool -> Bool -> Bool
|| (Bool -> Bool
not ([Output] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Output]
ps) Bool -> Bool -> Bool
&& Int
cws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
        then
            Maybe SomeException -> STM (Maybe SomeException)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
        else do
            Bool
app <- STM Bool
appDone
            Bool
gone <- ThreadManager -> STM Bool
T.isAllGone ThreadManager
threadManager
            if Bool
app Bool -> Bool -> Bool
&& Bool
gone Bool -> Bool -> Bool
&& [Output] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Output]
ps
                then
                    Maybe SomeException -> STM (Maybe SomeException)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SomeException -> STM (Maybe SomeException))
-> Maybe SomeException -> STM (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> SomeException
forall e. Exception e => e -> SomeException
E.toException HTTP2Error
ConnectionIsClosed
                else do
                    Maybe SomeException
recv <- TVar (Maybe SomeException) -> STM (Maybe SomeException)
forall a. TVar a -> STM a
readTVar TVar (Maybe SomeException)
receiverDone
                    case Maybe SomeException
recv of
                        Just SomeException
done ->
                            Maybe SomeException -> STM (Maybe SomeException)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SomeException -> STM (Maybe SomeException))
-> Maybe SomeException -> STM (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
done
                        Maybe SomeException
_otherwise ->
                            STM (Maybe SomeException)
forall a. STM a
retry
checkDone Context
_ TVar [Output]
_ Int
_ = Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing

frameSender :: Context -> Config -> IO E.SomeException
frameSender :: Context -> Config -> IO SomeException
frameSender
    ctx :: Context
ctx@Context{TQueue Output
outputQ :: Context -> TQueue Output
outputQ :: TQueue Output
outputQ, ControlQ
controlQ :: Context -> ControlQ
controlQ :: ControlQ
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 ByteString
Int -> TokenHeaderTable -> IO ()
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confReadNTimeout :: Bool
confOnInformational :: Int -> TokenHeaderTable -> IO ()
confOnInformational :: Config -> Int -> TokenHeaderTable -> IO ()
confReadNTimeout :: Config -> Bool
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} = do
        String -> IO ()
labelMe String
"H2 sender"
        -- DATA that has to wait for the connection window, in the order it
        -- came: see 'dequeue'.
        TVar [Output]
parked <- [Output] -> IO (TVar [Output])
forall a. a -> IO (TVar a)
newTVarIO []
        -- This catches an asynchronous exception.
        -- It is re-thrown by "runH2"
        TVar [Output] -> Int -> IO SomeException
loop TVar [Output]
parked Int
0 IO SomeException
-> (SomeException -> IO SomeException) -> IO SomeException
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO SomeException
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      where
        ----------------------------------------------------------------
        loop :: TVar [Output] -> Offset -> IO E.SomeException
        loop :: TVar [Output] -> Int -> IO SomeException
loop TVar [Output]
parked Int
off = do
            Maybe SomeException
mDone <- Context -> TVar [Output] -> Int -> IO (Maybe SomeException)
checkDone Context
ctx TVar [Output]
parked Int
off
            case Maybe SomeException
mDone of
                Just SomeException
done ->
                    SomeException -> IO SomeException
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SomeException
done
                Maybe SomeException
Nothing -> 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
$ TVar [Output] -> Int -> STM Switch
dequeue TVar [Output]
parked 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 SomeException -> IO SomeException
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar [Output] -> Int -> IO SomeException
loop TVar [Output]
parked Int
0
                        O Output
out ->
                            TVar [Output] -> Output -> Int -> IO Int
outputAndSync TVar [Output]
parked 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 SomeException) -> IO SomeException
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar [Output] -> Int -> IO SomeException
loop TVar [Output]
parked
                        Switch
Flush -> Int -> IO ()
flushN Int
off IO () -> IO SomeException -> IO SomeException
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar [Output] -> Int -> IO SomeException
loop TVar [Output]
parked 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 -> (ByteString -> IO ()) -> IO ()
forall a. Buffer -> Int -> (ByteString -> IO a) -> IO a
bufferIO Buffer
confWriteBuffer Int
n ByteString -> 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

        -- Only DATA is flow-controlled (RFC 9113, section 6.9), so only DATA
        -- waits for the connection window.  The whole output queue used to:
        -- with the window shut, no HEADERS, PUSH_PROMISE or RST_STREAM went
        -- out either, on any stream -- not even the response to a request
        -- that has no body, or the reset that would have freed some of the
        -- window.  Now outputs are taken as they come, and DATA there is no
        -- connection window for is parked ('outputAndSync') and goes out,
        -- first and in order, once there is.
        dequeue :: TVar [Output] -> Offset -> STM Switch
        dequeue :: TVar [Output] -> Int -> STM Switch
dequeue TVar [Output]
parked Int
off = do
            Bool
isEmptyC <- ControlQ -> STM Bool
isEmptyControlQ ControlQ
controlQ
            if Bool
isEmptyC
                then do
                    [Output]
ps <- TVar [Output] -> STM [Output]
forall a. TVar a -> STM a
readTVar TVar [Output]
parked
                    Int
cws <- Context -> STM Int
connectionWindowSizeSTM Context
ctx
                    case [Output]
ps of
                        -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit
                        Output
p : [Output]
rest | Int
cws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
                            TVar [Output] -> [Output] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Output]
parked [Output]
rest
                            Switch -> STM Switch
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Switch -> STM Switch) -> Switch -> STM Switch
forall a b. (a -> b) -> a -> b
$ Output -> Switch
O Output
p
                        [Output]
_ -> do
                            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
<$> ControlQ -> STM Control
dequeueControlSTM ControlQ
controlQ

        ----------------------------------------------------------------
        copyAll :: [ByteString] -> 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 (ByteString
x : [ByteString]
xs) Buffer
buf = Buffer -> ByteString -> IO Buffer
copy Buffer
buf ByteString
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
>>= [ByteString] -> Buffer -> IO Buffer
copyAll [ByteString]
xs

        -- called with off == 0
        control :: Control -> IO ()
        control :: Control -> IO ()
control (CFrames Maybe SettingsList
ms [ByteString]
xs) = do
            Buffer
buf <- [ByteString] -> Buffer -> IO Buffer
copyAll [ByteString]
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 :: TVar [Output] -> Output -> Offset -> IO Offset
        -- "handler" catches an asynchronous exception and
        -- re-throws it.
        outputAndSync :: TVar [Output] -> Output -> Int -> IO Int
outputAndSync TVar [Output]
parked 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 (Stream -> Int -> SomeException -> IO Int
forall {a}. Stream -> a -> SomeException -> IO a
handler Stream
strm 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 do
                    case OutputType
otyp of
                        OReset Maybe SomeException
mErr
                            | Bool -> Bool
not (StreamState -> Bool
isClosed StreamState
state) ->
                                -- RST_STREAM is the only frame we can still send
                                -- after half-closing
                                Stream -> Maybe SomeException -> IO ()
resetStreamWith Stream
strm Maybe SomeException
mErr
                        OutputType
_otherwise ->
                            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    -- Nothing more can go out on this stream, but whoever
                    -- enqueued this output is waiting in 'syncWithSender'' to
                    -- be told so.  Dropping the notification parked that
                    -- thread on an MVar nothing would ever fill, until the
                    -- timeout manager killed it -- one stranded worker per
                    -- stream the peer resets while a response is in flight.
                    Maybe Output -> IO ()
sync Maybe Output
forall a. Maybe a
Nothing
                    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'
                    OInformational [Header]
hdr -> do
                        Int
off' <- Stream -> [Header] -> Int -> IO Int
outputInformational Stream
strm [Header]
hdr Int
off
                        Maybe Output -> IO ()
sync Maybe Output
forall a. Maybe a
Nothing
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off'
                    OReset Maybe SomeException
mErr -> do
                        Stream -> Maybe SomeException -> IO ()
resetStreamWith Stream
strm Maybe SomeException
mErr
                        Maybe Output -> IO ()
sync Maybe Output
forall a. Maybe a
Nothing
                        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
                        let lim :: Int
lim = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
cws Int
sws
                        case OutputType
otyp of
                            ONext{}
                                | Int
cws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> do
                                    -- To wait for the connection window,
                                    -- without holding up anything else.
                                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [Output] -> ([Output] -> [Output]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Output]
parked ([Output] -> [Output] -> [Output]
forall a. [a] -> [a] -> [a]
++ [Output
out])
                                    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                                | Int
lim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> do
                                    -- No room for any of the body: the
                                    -- window was shut after this was queued
                                    -- (a SETTINGS_INITIAL_WINDOW_SIZE
                                    -- decrease, say).  Filling a DATA frame
                                    -- into no room reads 0 octets of a file,
                                    -- which is taken for its end; handed back
                                    -- instead, it is queued again once the
                                    -- window opens.
                                    Maybe Output -> IO ()
sync (Maybe Output -> IO ()) -> Maybe Output -> IO ()
forall a b. (a -> b) -> a -> b
$ Output -> Maybe Output
forall a. a -> Maybe a
Just Output
out
                                    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                            OutputType
_ -> do
                                (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'

        ----------------------------------------------------------------
        handler :: Stream -> a -> SomeException -> IO a
handler Stream
strm a
off SomeException
e
            | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
e = SomeException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
            | Bool
otherwise = do
                Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
InternalError SomeException
e
                a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
off

        -- 'e' is the reason for the reset, not something thrown to the
        -- sender.  It may well be asynchronous: a streaming body killed
        -- by 'cancel' passes the exception to 'outBodyCancel'.  Throwing
        -- it here would kill the sender and the whole connection with it.
        -- Asynchronous exceptions actually thrown to the sender are
        -- re-thrown by 'handler'.
        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 :: ByteString
rst = ErrorCode -> Int -> ByteString
resetFrame ErrorCode
err (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Stream -> Int
streamNumber Stream
strm
            ControlQ -> Control -> IO ()
enqueueControl ControlQ
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ByteString
rst]

        resetStreamWith :: Stream -> Maybe E.SomeException -> IO ()
        resetStreamWith :: Stream -> Maybe SomeException -> IO ()
resetStreamWith Stream
strm (Just SomeException
err) =
            Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
InternalError SomeException
err
        resetStreamWith Stream
strm Maybe SomeException
Nothing =
            Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
Cancel (CancelledStream -> SomeException
forall e. Exception e => e -> SomeException
E.toException CancelledStream
CancelledStream)

        ----------------------------------------------------------------
        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 TokenHeaderTable
toTokenHeaderTable ([Header] -> IO TokenHeaderTable)
-> [Header] -> IO TokenHeaderTable
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')

        ----------------------------------------------------------------
        -- Emit an informational (1xx) HEADERS section. Unlike 'outputHeader',
        -- this never sets END_STREAM and never half-closes the stream, so the
        -- final response can still be sent afterwards.
        outputInformational
            :: Stream
            -> [Header]
            -> Offset
            -> IO Offset
        outputInformational :: Stream -> [Header] -> Int -> IO Int
outputInformational Stream
strm [Header]
hdr Int
off0 = do
            let sid :: Int
sid = Stream -> Int
streamNumber Stream
strm
            (TokenHeaderList
ths, ValueTable
_) <- [Header] -> IO TokenHeaderTable
toTokenHeaderTable ([Header] -> IO TokenHeaderTable)
-> [Header] -> IO TokenHeaderTable
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
False {- not endOfStream -} Int
off0
            Int -> IO Int
flushIfNecessary Int
off'

        ----------------------------------------------------------------
        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
tm <- TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
forall {b}. Ptr b
datBuf Int
datPayloadLen
                    let tlrmkr' :: TrailersMaker
tlrmkr' = case NextTrailersMaker
tm of
                            NextTrailersMaker TrailersMaker
t -> TrailersMaker
t
                            NextTrailersMaker
_ -> TrailersMaker
defaultTrailersMaker
                    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.
                    Stream -> Maybe SomeException -> IO ()
resetStreamWith Stream
strm Maybe SomeException
mErr
                    (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
            -- Most blocks fit where they are going: encode in place, which
            -- is one HEADERS frame and no copying.
            (TokenHeaderList
rest, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths0
            if TokenHeaderList -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TokenHeaderList
rest
                then do
                    let buf :: Ptr b
buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off0
                    FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameHeaders Int
kvlen Int
sid (FrameType -> ByteString -> FrameFlags
getFlag FrameType
FrameHeaders ByteString
BS.Lazy.empty) 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
offkv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kvlen
                else do
                    -- It did not fit.  What was written is the start of the
                    -- block, and the dynamic table has taken it into
                    -- account, so it is kept; the rest is encoded after it,
                    -- and the whole block then starts in a fresh buffer to
                    -- avoid emitting a tiny HEADERS frame.
                    ByteString
start <- CStringLen -> IO ByteString
BS.packCStringLen (Ptr Any -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Any
forall {b}. Ptr b
bufkv, Int
kvlen)
                    ByteString
ths1 <- Context -> Int -> TokenHeaderList -> IO ByteString
hpackEncodeHeaderRest Context
ctx (Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frameHeaderLength) TokenHeaderList
rest
                    Int -> ByteString -> FrameType -> IO Int
continue Int
off0 (ByteString -> ByteString
BS.Lazy.fromStrict ByteString
start ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ths1) FrameType
FrameHeaders
          where
            eos :: FrameFlags -> FrameFlags
eos = if Bool
endOfStream then FrameFlags -> FrameFlags
setEndStream else FrameFlags -> FrameFlags
forall a. a -> a
id
            getFlag :: FrameType -> ByteString -> FrameFlags
getFlag FrameType
ft ByteString
ths =
                (if FrameType
ft FrameType -> FrameType -> Bool
forall a. Eq a => a -> a -> Bool
== FrameType
FrameHeaders then FrameFlags -> FrameFlags
eos else FrameFlags -> FrameFlags
forall a. a -> a
id) (FrameFlags -> FrameFlags) -> FrameFlags -> FrameFlags
forall a b. (a -> b) -> a -> b
$
                    if ByteString -> Bool
BS.Lazy.null ByteString
ths then FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags else FrameFlags
defaultFlags

            continue :: Offset -> BS.Lazy.ByteString -> FrameType -> IO Offset
            continue :: Int -> ByteString -> FrameType -> IO Int
continue Int
off ByteString
ths FrameType
_ | ByteString -> Bool
BS.Lazy.null ByteString
ths = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
            continue Int
off ByteString
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
                (ByteString
ths', Int
kvlen') <-
                    Buffer -> Int -> ByteString -> IO (ByteString, Int)
copyFragment Buffer
forall {b}. Ptr b
bufHeaderPayload Int
headerPayloadLim ByteString
ths
                let flag :: FrameFlags
flag = FrameType -> ByteString -> FrameFlags
getFlag FrameType
ft ByteString
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 -> ByteString -> FrameType -> IO Int
continue Int
off' ByteString
ths' FrameType
FrameContinuation

        -- Copy as much of the block as fits; return the rest and the number of bytes copied
        copyFragment
            :: Buffer -> Int -> BS.Lazy.ByteString -> IO (BS.Lazy.ByteString, Int)
        copyFragment :: Buffer -> Int -> ByteString -> IO (ByteString, Int)
copyFragment Buffer
buf Int
lim ByteString
ths = do
            let (ByteString
frag, ByteString
rest) = Int64 -> ByteString -> (ByteString, ByteString)
BS.Lazy.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
lim)) ByteString
ths
            Buffer
_ <- (Buffer -> ByteString -> IO Buffer)
-> Buffer -> [ByteString] -> IO Buffer
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Buffer -> ByteString -> IO Buffer
copy Buffer
buf (ByteString -> [ByteString]
BS.Lazy.toChunks ByteString
frag)
            (ByteString, Int) -> IO (ByteString, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
rest, Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
BS.Lazy.length ByteString
frag))

        ----------------------------------------------------------------
        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
                    NextTrailersMaker
tm <- TrailersMaker
tlrmkr Maybe ByteString
forall a. Maybe a
Nothing
                    let trailers :: [Header]
trailers = case NextTrailersMaker
tm of
                            Trailers [Header]
t -> [Header]
t
                            NextTrailersMaker
_ -> []
                    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 TokenHeaderTable
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
                    }