@@ -16,7 +16,7 @@ import Data.Maybe (isNothing)
1616import Foreign.Ptr
1717import Network.HPACK (setLimitForEncoding)
1818import Network.HTTP2
19−import Network.HTTP2.Priority (dequeue)
19+import Network.HTTP2.Priority (dequeueSTM)
2020import Network.Wai
2121import Network.Wai.Handler.Warp.Buffer
2222import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
@@ -47,12 +47,6 @@ data Leftover = LZero
4747
4848----------------------------------------------------------------
4949
50−getConnectionWindowSizeWhenReady :: Context -> IO WindowSize
51−getConnectionWindowSizeWhenReady Context{connectionWindow} = atomically $ do
52− w <- readTVar connectionWindow
53− check (w > 0)
54− return w
55−
5650getStreamWindowSize :: Stream -> IO WindowSize
5751getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow
5852
@@ -67,24 +61,30 @@ waitStreaming tbq = do
6761 check (isEmpty == False)
6862
6963frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO ()
70−frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
64+frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
7165 conn@Connection{connWriteBuffer,connBufferSize,connSendAll}
7266 ii settings = loop `E.catch` ignore
7367 where
74− bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
75− headerPayloadLim = connBufferSize - frameHeaderLength
76−
77− loop = dequeue outputQ >>= \(_sid,pre,out) -> switch out pre
78−
79− ignore :: E.SomeException -> IO ()
80− ignore _ = return ()
81−
82− switch OFinish _ = return ()
83− switch (OGoaway frame) _ = connSendAll frame
84− switch (OFrame frame) _ = do
68+ dequeueControl = Left <$> readTQueue controlQ
69+ dequeueData = Right <$> do
70+ w <- readTVar connectionWindow
71+ check (w > 0)
72+ dequeueSTM outputQ
73+
74+ loop = do
75+ ex <- atomically (dequeueControl `orElse` dequeueData)
76+ case ex of
77+ Left ctl -> control ctl
78+ Right (_,pre,out) -> do
79+ writeIORef (streamPrecedence (outputStream out)) pre
80+ switch out
81+
82+ control CFinish = return ()
83+ control (CGoaway frame) = connSendAll frame
84+ control (CFrame frame) = do
8585 connSendAll frame
8686 loop
87− switch (OSettings frame alist) _ = do
87+ control (CSettings frame alist) = do
8888 connSendAll frame
8989 case lookup SettingsHeaderTableSize alist of
9090 Nothing -> return ()
@@ -92,18 +92,17 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
9292 dyntbl <- readIORef encodeDynamicTable
9393 setLimitForEncoding siz dyntbl
9494 loop
95− switch out@(ONext strm curr binfo) pre = do
96− writeIORef (streamPrecedence strm) pre
95+
96+ switch out@(ONext strm curr binfo) = do
9797 whenReadyOrEnqueueAgain strm binfo out $ \sws -> do
98− cws <- getConnectionWindowSizeWhenReady ctx
98+ cws <- atomically $ readTVar connectionWindow
9999 let !lim = min cws sws
100100 -- Data frame payload
101101 Next datPayloadLen mnext <- curr lim
102102 fillDataHeaderSend strm 0 datPayloadLen mnext
103103 maybeEnqueueNext strm mnext binfo
104104 loop
105− switch out@(OResponse strm rsp binfo) pre = do
106− writeIORef (streamPrecedence strm) pre
105+ switch out@(OResponse strm rsp binfo) = do
107106 whenReadyOrEnqueueAgain strm binfo out $ \sws -> do
108107 -- Header frame and Continuation frame
109108 let sid = streamNumber strm
@@ -118,7 +117,7 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
118117 -- Data frame payload
119118 (off, _) <- sendHeadersIfNecessary total
120119 let payloadOff = off + frameHeaderLength
121− cws <- getConnectionWindowSizeWhenReady ctx
120+ cws <- atomically $ readTVar connectionWindow
122121 let !lim = min cws sws
123122 Next datPayloadLen mnext <-
124123 fillResponseBodyGetNext conn ii payloadOff lim rsp
@@ -133,7 +132,7 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
133132 Persist sq -> do
134133 (off, needSend) <- sendHeadersIfNecessary total
135134 let payloadOff = off + frameHeaderLength
136− cws <- getConnectionWindowSizeWhenReady ctx
135+ cws <- atomically $ readTVar connectionWindow
137136 let !lim = min cws sws
138137 Next datPayloadLen mnext <-
139138 fillStreamBodyGetNext conn payloadOff lim sq strm
@@ -166,9 +165,8 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
166165 body sws
167166 resetStream e = do
168167 closed ctx strm (ResetByMe e)
169− let rst = resetFrame InternalError $ streamNumber strm
170− eout = OFrame rst
171− enqueueOutputControl outputQ eout
168+ let !rst = resetFrame InternalError $ streamNumber strm
169+ enqueueControl controlQ $ CFrame rst
172170
173171 -- Flush the connection buffer to the socket, where the first 'n' bytes of
174172 -- the buffer are filled.
@@ -246,6 +244,13 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
246244 where
247245 hinfo = FrameHeader len flag sid
248246
247+ bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
248+ headerPayloadLim = connBufferSize - frameHeaderLength
249+
250+ ignore :: E.SomeException -> IO ()
251+ ignore _ = return ()
252+
253+
249254----------------------------------------------------------------
250255
251256{-