{-# 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. (HasCallStack, 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. (HasCallStack, Exception e) => e -> IO a
E.throwIO HTTP2Error
e
| Bool
otherwise = HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> HTTP2Error
BadThingHappen SomeException
se
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings Context{IORef Settings
peerSettings :: IORef Settings
peerSettings :: Context -> IORef Settings
peerSettings, TVar OddStreamTable
oddStreamTable :: TVar OddStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
oddStreamTable, TVar EvenStreamTable
evenStreamTable :: TVar EvenStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
evenStreamTable} SettingsList
peerAlist = do
oldws <- Settings -> 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
modifyIORef' peerSettings $ \Settings
old -> Settings -> SettingsList -> Settings
fromSettingsList Settings
old SettingsList
peerAlist
newws <- initialWindowSize <$> readIORef peerSettings
let dif = WindowSize
newws WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
oldws
when (dif /= 0) $ do
getOddStreams oddStreamTable >>= updateAllStreamTxFlow dif
getEvenStreams evenStreamTable >>= updateAllStreamTxFlow 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
SockAddr
Manager
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
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> WindowSize -> IO FieldValue
confSendAll :: Config -> FieldValue -> IO ()
confBufferSize :: Config -> WindowSize
confWriteBuffer :: Config -> Buffer
..} = 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
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 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
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
buflim <- IORef WindowSize -> IO WindowSize
forall a. IORef a -> IO a
readIORef IORef WindowSize
outputBufferLimit
if off <= buflim - 512
then return off
else do
flushN off
return 0
dequeue :: Offset -> STM Switch
dequeue :: WindowSize -> STM Switch
dequeue WindowSize
off = do
isEmptyC <- TQueue Control -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
if isEmptyC
then do
waitConnectionWindowSize ctx
isEmptyO <- isEmptyTQueue outputQ
if isEmptyO
then if off /= 0 then return Flush else retry
else O <$> readTQueue outputQ
else C <$> readTQueue controlQ
copyAll :: [FieldValue] -> Buffer -> IO Buffer
copyAll [] Buffer
buf = Buffer -> IO Buffer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buf
copyAll (FieldValue
x : [FieldValue]
xs) Buffer
buf = Buffer -> FieldValue -> IO Buffer
copy Buffer
buf FieldValue
x IO Buffer -> (Buffer -> IO Buffer) -> IO Buffer
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FieldValue] -> Buffer -> IO Buffer
copyAll [FieldValue]
xs
control :: Control -> IO ()
control :: Control -> IO ()
control (CFinish HTTP2Error
e) = HTTP2Error -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO HTTP2Error
e
control (CFrames Maybe SettingsList
ms [FieldValue]
xs) = do
buf <- [FieldValue] -> Buffer -> IO Buffer
copyAll [FieldValue]
xs Buffer
confWriteBuffer
let off = Buffer
buf Buffer -> Buffer -> WindowSize
forall a b. Ptr a -> Ptr b -> WindowSize
`minusPtr` Buffer
confWriteBuffer
flushN off
case ms of
Maybe SettingsList
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just SettingsList
peerAlist -> do
Context -> SettingsList -> IO ()
updatePeerSettings Context
ctx SettingsList
peerAlist
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
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
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
state <- Stream -> IO StreamState
readStreamState Stream
strm
if isHalfClosedLocal state
then return off
else case otyp of
OHeader [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr -> do
(off', mout') <- Stream
-> [Header]
-> Maybe DynaNext
-> TrailersMaker
-> (Maybe Output -> IO ())
-> WindowSize
-> IO (WindowSize, Maybe Output)
outputHeader Stream
strm [Header]
hdr Maybe DynaNext
mnext TrailersMaker
tlrmkr Maybe Output -> IO ()
sync WindowSize
off
sync mout'
return off'
OutputType
_ -> do
sws <- Stream -> IO WindowSize
getStreamWindowSize Stream
strm
cws <- getConnectionWindowSize ctx
let lim = WindowSize -> WindowSize -> WindowSize
forall a. Ord a => a -> a -> a
min WindowSize
cws WindowSize
sws
(off', mout') <- output out off lim
sync mout'
return off'
resetStream :: Stream -> ErrorCode -> E.SomeException -> IO ()
resetStream :: Stream -> ErrorCode -> SomeException -> IO ()
resetStream Stream
strm ErrorCode
err SomeException
e = 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
let sid :: WindowSize
sid = Stream -> WindowSize
streamNumber Stream
strm
endOfStream :: Bool
endOfStream = Maybe DynaNext -> Bool
forall a. Maybe a -> Bool
isNothing Maybe DynaNext
mnext
(ths, _) <- [Header] -> IO (TokenHeaderList, ValueTable)
toTokenHeaderTable ([Header] -> IO (TokenHeaderList, ValueTable))
-> [Header] -> IO (TokenHeaderList, ValueTable)
forall a b. (a -> b) -> a -> b
$ [Header] -> [Header]
fixHeaders [Header]
hdr
off' <- headerContinue sid ths endOfStream off0
off <- flushIfNecessary off'
case mnext of
Maybe DynaNext
Nothing -> do
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
buflim <- IORef WindowSize -> IO WindowSize
forall a. IORef a -> IO a
readIORef IORef WindowSize
outputBufferLimit
let payloadOff = WindowSize
off0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
frameHeaderLength
datBuf = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
payloadOff
datBufSiz = WindowSize
buflim WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
payloadOff
curr datBuf (min datBufSiz lim) >>= \Next
next ->
case Next
next of
Next WindowSize
datPayloadLen Bool
reqflush Maybe DynaNext
mnext -> do
NextTrailersMaker tlrmkr' <- TrailersMaker -> Buffer -> WindowSize -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
forall {b}. Ptr b
datBuf WindowSize
datPayloadLen
fillDataHeader
strm
off0
datPayloadLen
mnext
tlrmkr'
out
reqflush
CancelNext Maybe SomeException
mErr -> do
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
let sid :: WindowSize
sid = Stream -> WindowSize
streamNumber Stream
strm
len <- WindowSize
-> WindowSize -> TokenHeaderList -> WindowSize -> IO WindowSize
pushPromise WindowSize
pid WindowSize
sid TokenHeaderList
ths WindowSize
off0
off <- flushIfNecessary $ off0 + frameHeaderLength + len
return (off, Nothing)
output Output
_ WindowSize
_ WindowSize
_ = IO (WindowSize, Maybe Output)
forall a. HasCallStack => a
undefined
headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset
headerContinue :: WindowSize
-> TokenHeaderList -> Bool -> WindowSize -> IO WindowSize
headerContinue WindowSize
sid TokenHeaderList
ths0 Bool
endOfStream WindowSize
off0 = do
buflim <- IORef WindowSize -> IO WindowSize
forall a. IORef a -> IO a
readIORef IORef WindowSize
outputBufferLimit
let offkv = WindowSize
off0 WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
frameHeaderLength
bufkv = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
offkv
limkv = WindowSize
buflim WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
offkv
(ths, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0
if kvlen == 0
then continue off0 ths FrameHeaders
else do
let flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths
buf = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
off0
off = WindowSize
offkv WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
kvlen
fillFrameHeader FrameHeaders kvlen sid flag buf
continue off ths FrameContinuation
where
eos :: FrameFlags -> FrameFlags
eos = if Bool
endOfStream then FrameFlags -> FrameFlags
setEndStream else FrameFlags -> FrameFlags
forall a. a -> a
id
getFlag :: [a] -> FrameFlags
getFlag [] = FrameFlags -> FrameFlags
eos (FrameFlags -> FrameFlags) -> FrameFlags -> FrameFlags
forall a b. (a -> b) -> a -> b
$ FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags
getFlag [a]
_ = FrameFlags -> FrameFlags
eos (FrameFlags -> 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
buflim <- IORef WindowSize -> IO WindowSize
forall a. IORef a -> IO a
readIORef IORef WindowSize
outputBufferLimit
let bufHeaderPayload = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
frameHeaderLength
headerPayloadLim = WindowSize
buflim WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
frameHeaderLength
(ths', kvlen') <-
hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths
when (ths == ths') $
E.throwIO $
ConnectionErrorIsSent CompressionError sid "cannot compress the header"
let flag = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths'
off' = WindowSize
frameHeaderLength WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
kvlen'
fillFrameHeader ft kvlen' sid flag confWriteBuffer
continue off' ths' FrameContinuation
fillDataHeader
:: Stream
-> Offset
-> Int
-> Maybe DynaNext
-> (Maybe ByteString -> IO NextTrailersMaker)
-> Output
-> Bool
-> IO (Offset, Maybe Output)
fillDataHeader :: Stream
-> 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
(mtrailers, flag) <- do
Trailers trailers <- TrailersMaker
tlrmkr Maybe FieldValue
forall a. Maybe a
Nothing
if null trailers
then return (Nothing, setEndStream defaultFlags)
else return (Just trailers, defaultFlags)
off' <-
if datPayloadLen /= 0 || isNothing mtrailers
then do
decreaseWindowSize ctx strm datPayloadLen
fillFrameHeader FrameData datPayloadLen streamNumber flag buf
return $ off + frameHeaderLength + datPayloadLen
else
return off
off'' <- handleTrailers mtrailers off'
halfClosedLocal ctx strm Finished
if reqflush
then do
flushN off''
return (0, Nothing)
else return (off'', Nothing)
where
handleTrailers :: Maybe [Header] -> 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
(ths, _) <- [Header] -> IO (TokenHeaderList, ValueTable)
toTokenHeaderTable [Header]
trailers
headerContinue streamNumber ths True 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
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
(_, kvlen) <- Context
-> Buffer
-> WindowSize
-> TokenHeaderList
-> IO (TokenHeaderList, WindowSize)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv WindowSize
limkv TokenHeaderList
ths
let flag = FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags
buf = Buffer
confWriteBuffer Buffer -> WindowSize -> Ptr b
forall a b. Ptr a -> WindowSize -> Ptr b
`plusPtr` WindowSize
off
len = WindowSize
kvlen WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
+ WindowSize
4
fillFrameHeader FramePushPromise len pid flag buf
return 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