@@ -10,7 +10,7 @@ import Control.Applicative
1010import Control.Concurrent (forkIO)
1111import Control.Concurrent.STM
1212import qualified Control.Exception as E
13−import Control.Monad (void, unless)
13+import Control.Monad (unless, void, when)
1414import qualified Data.ByteString as BS
1515import qualified Data.ByteString.Builder.Extra as B
1616import Foreign.Ptr
@@ -111,27 +111,44 @@ frameSender ctx@Context{outputQ,connectionWindow}
111111 case aux of
112112 Oneshot True -> do -- hasBody
113113 -- Data frame payload
114− off <- sendHeadersIfNecessary total
115− Next datPayloadLen mnext <- fillResponseBodyGetNext conn ii off lim rsp
116− fillDataHeaderSend strm total datPayloadLen mnext pri
114+ (off, _) <- sendHeadersIfNecessary total
115+ let payloadOff = off + frameHeaderLength
116+ Next datPayloadLen mnext <-
117+ fillResponseBodyGetNext conn ii payloadOff lim rsp
118+ fillDataHeaderSend strm total datPayloadLen mnext
119+ maybeEnqueueNext strm mnext pri
117120 Oneshot False -> do
118121 -- "closed" must be before "connSendAll". If not,
119122 -- the context would be switched to the receiver,
120123 -- resulting the inconsistency of concurrency.
121124 closed ctx strm Finished
122− bufferIO connWriteBuffer total connSendAll
125+ flushN total
123126 Persist sq tvar -> do
124− off <- sendHeadersIfNecessary total
125− Next datPayloadLen mnext <- fillStreamBodyGetNext conn off lim sq tvar
126− fillDataHeaderSend strm total datPayloadLen mnext pri
127+ (off, needSend) <- sendHeadersIfNecessary total
128+ let payloadOff = off + frameHeaderLength
129+ Next datPayloadLen mnext <-
130+ fillStreamBodyGetNext conn payloadOff lim sq tvar
131+ -- If no data was immediately available, avoid sending an
132+ -- empty data frame.
133+ if datPayloadLen > 0 then
134+ fillDataHeaderSend strm total datPayloadLen mnext
135+ else
136+ when needSend $ flushN off
137+ maybeEnqueueNext strm mnext pri
127138 loop
128139 switch out@(ONext strm curr) pri = unlessClosed ctx conn strm $ do
129140 checkWindowSize connectionWindow (streamWindow strm) outputQ out pri $ \lim -> do
130141 -- Data frame payload
131142 Next datPayloadLen mnext <- curr lim
132− fillDataHeaderSend strm 0 datPayloadLen mnext pri
143+ fillDataHeaderSend strm 0 datPayloadLen mnext
144+ maybeEnqueueNext strm mnext pri
133145 loop
134146
147+ -- Flush the connection buffer to the socket, where the first 'n' bytes of
148+ -- the buffer are filled.
149+ flushN :: Int -> IO ()
150+ flushN n = bufferIO connWriteBuffer n connSendAll
151+
135152 headerContinue sid rsp endOfStream = do
136153 builder <- hpackEncodeHeader ctx ii settings rsp
137154 (len, signal) <- B.runBuilder builder bufHeaderPayload headerPayloadLim
@@ -144,8 +161,7 @@ frameSender ctx@Context{outputQ,connectionWindow}
144161
145162 continue _ len B.Done = return len
146163 continue sid len (B.More _ writer) = do
147− let total = len + frameHeaderLength
148− bufferIO connWriteBuffer total connSendAll
164+ flushN $ len + frameHeaderLength
149165 (len', signal') <- writer bufHeaderPayload headerPayloadLim
150166 let flag = case signal' of
151167 B.Done -> setEndHeader defaultFlags
@@ -153,8 +169,7 @@ frameSender ctx@Context{outputQ,connectionWindow}
153169 fillFrameHeader FrameContinuation len' sid flag connWriteBuffer
154170 continue sid len' signal'
155171 continue sid len (B.Chunk bs writer) = do
156− let total = len + frameHeaderLength
157− bufferIO connWriteBuffer total connSendAll
172+ flushN $ len + frameHeaderLength
158173 let (bs1,bs2) = BS.splitAt headerPayloadLim bs
159174 len' = BS.length bs1
160175 void $ copy bufHeaderPayload bs1
@@ -164,15 +179,28 @@ frameSender ctx@Context{outputQ,connectionWindow}
164179 else
165180 continue sid len' (B.Chunk bs2 writer)
166181
167− sendHeadersIfNecessary total = do
168− let datPayloadOff = total + frameHeaderLength
169− if datPayloadOff < connBufferSize then
170− return datPayloadOff
171− else do
172− bufferIO connWriteBuffer total connSendAll
173− return frameHeaderLength
182+ -- True if the connection buffer has room for a 1-byte data frame.
183+ canFitDataFrame total = total + frameHeaderLength < connBufferSize
184+
185+ -- Re-enqueue the stream in the output queue if more output is immediately
186+ -- available; do nothing otherwise. If the stream is not finished, it must
187+ -- already have been written to the 'TVar' owned by 'waiter', which will
188+ -- put it back into the queue when more output becomes available.
189+ maybeEnqueueNext :: Stream -> Control DynaNext -> Priority -> IO ()
190+ maybeEnqueueNext strm (CNext next) = enqueue outputQ (ONext strm next)
191+ maybeEnqueueNext _ _ = const $ return ()
192+
174193
175− fillDataHeaderSend strm otherLen datPayloadLen mnext pri = do
194+ -- Send headers if there is not room for a 1-byte data frame, and return
195+ -- the offset of the next frame's first header byte and whether the headers
196+ -- still need to be sent.
197+ sendHeadersIfNecessary total
198+ | canFitDataFrame total = return (total, True)
199+ | otherwise = do
200+ flushN total
201+ return (0, False)
202+
203+ fillDataHeaderSend strm otherLen datPayloadLen mnext = do
176204 -- Data frame header
177205 let sid = streamNumber strm
178206 buf = connWriteBuffer `plusPtr` otherLen
@@ -187,14 +215,10 @@ frameSender ctx@Context{outputQ,connectionWindow}
187215 case mnext of
188216 CFinish -> closed ctx strm Finished
189217 _ -> return ()
190− bufferIO connWriteBuffer total connSendAll
218+ flushN total
191219 atomically $ do
192220 modifyTVar' connectionWindow (subtract datPayloadLen)
193221 modifyTVar' (streamWindow strm) (subtract datPayloadLen)
194− case mnext of
195− CFinish -> return ()
196− CNext next -> enqueue outputQ (ONext strm next) pri
197− CNone -> return ()
198222
199223 fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf
200224 where