@@ -1,536 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE BangPatterns, CPP #-}
3−{-# LANGUAGE NamedFieldPuns #-}
4−
5−module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where
6−
7−import Control.Concurrent.STM
8−import qualified Control.Exception as E
9−import qualified Data.ByteString as BS
10−import Data.ByteString.Builder (Builder)
11−import qualified Data.ByteString.Builder.Extra as B
12−import Data.IORef
13−import Foreign.Ptr (Ptr, plusPtr)
14−import Foreign.Storable (poke)
15−import Network.HPACK (setLimitForEncoding, toHeaderTable)
16−import Network.HTTP2
17−import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)
18−import Network.Wai
19−
20−#ifdef WINDOWS
21−import qualified System.IO as IO
22−#else
23−import Network.Wai.Handler.Warp.FdCache
24−import Network.Wai.Handler.Warp.SendFile (positionRead)
25−import qualified Network.Wai.Handler.Warp.Timeout as T
26−#endif
27−
28−import Network.Wai.Handler.Warp.Buffer
29−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
30−import Network.Wai.Handler.Warp.HTTP2.HPACK
31−import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)
32−import Network.Wai.Handler.Warp.HTTP2.Types
33−import Network.Wai.Handler.Warp.Imports hiding (readInt)
34−import qualified Network.Wai.Handler.Warp.Settings as S
35−import Network.Wai.Handler.Warp.Types
36−
37−----------------------------------------------------------------
38−
39−data Leftover = LZero
40− | LOne B.BufferWriter
41− | LTwo ByteString B.BufferWriter
42−
43−----------------------------------------------------------------
44−
45−{-# INLINE getStreamWindowSize #-}
46−getStreamWindowSize :: Stream -> IO WindowSize
47−getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow
48−
49−{-# INLINE waitStreamWindowSize #-}
50−waitStreamWindowSize :: Stream -> IO ()
51−waitStreamWindowSize Stream{streamWindow} = atomically $ do
52− w <- readTVar streamWindow
53− check (w > 0)
54−
55−{-# INLINE waitStreaming #-}
56−waitStreaming :: TBQueue a -> IO ()
57−waitStreaming tbq = atomically $ do
58− isEmpty <- isEmptyTBQueue tbq
59− check (not isEmpty)
60−
61−data Switch = C Control
62− | O (StreamId,Precedence,Output)
63− | Flush
64−
65−frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()
66−frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
67− conn@Connection{connWriteBuffer,connBufferSize,connSendAll}
68− settings mgr = loop 0 `E.catch` ignore
69− where
70− dequeue off = do
71− isEmpty <- isEmptyTQueue controlQ
72− if isEmpty then do
73− w <- readTVar connectionWindow
74− check (w > 0)
75− emp <- isEmptySTM outputQ
76− if emp then
77− if off /= 0 then return Flush else retry
78− else
79− O <$> dequeueSTM outputQ
80− else
81− C <$> readTQueue controlQ
82−
83− loop off = do
84− x <- atomically $ dequeue off
85− case x of
86− C ctl -> do
87− when (off /= 0) $ flushN off
88− off' <- control ctl off
89− when (off' >= 0) $ loop off'
90− O (_,pre,out) -> do
91− let strm = outputStream out
92− writeIORef (streamPrecedence strm) pre
93− off' <- outputOrEnqueueAgain out off
94− case off' of
95− 0 -> loop 0
96− _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding
97− | otherwise -> loop off'
98− Flush -> flushN off >> loop 0
99−
100− control CFinish _ = return (-1)
101− control (CGoaway frame) _ = connSendAll frame >> return (-1)
102− control (CFrame frame) _ = connSendAll frame >> return 0
103− control (CSettings frame alist) _ = do
104− connSendAll frame
105− setLimit alist
106− return 0
107− control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case
108− let !buf = connWriteBuffer `plusPtr` off
109− !off' = off + BS.length frame1 + BS.length frame2
110− buf' <- copy buf frame1
111− void $ copy buf' frame2
112− setLimit alist
113− return off'
114−
115− {-# INLINE setLimit #-}
116− setLimit alist = case lookup SettingsHeaderTableSize alist of
117− Nothing -> return ()
118− Just siz -> setLimitForEncoding siz encodeDynamicTable
119−
120− output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do
121− -- Data frame payload
122− let !buf = connWriteBuffer `plusPtr` off0
123− !siz = connBufferSize - off0
124− Next datPayloadLen mnext <- curr buf siz lim
125− off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D
126− maybeEnqueueNext out mnext
127− return off
128−
129− output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do
130− -- Header frame and Continuation frame
131− let !sid = streamNumber strm
132− !endOfStream = case rspn of
133− RspnNobody _ _ -> True
134− _ -> False
135− ths <- fixHeaders ctx rspn ii settings
136− kvlen <- headerContinue sid ths endOfStream off0
137− off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen
138− case rspn of
139− RspnNobody _ _ -> do
140− closed ctx strm Finished
141− return off
142− RspnFile _ _ path mpart -> do
143− -- Data frame payload
144− let payloadOff = off + frameHeaderLength
145− Next datPayloadLen mnext <-
146− fillFileBodyGetNext conn ii payloadOff lim path mpart
147− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
148− maybeEnqueueNext out mnext
149− return off'
150− RspnBuilder _ _ builder -> do
151− -- Data frame payload
152− let payloadOff = off + frameHeaderLength
153− Next datPayloadLen mnext <-
154− fillBuilderBodyGetNext conn ii payloadOff lim builder
155− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
156− maybeEnqueueNext out mnext
157− return off'
158− RspnStreaming _ _ tbq -> do
159− let payloadOff = off + frameHeaderLength
160− Next datPayloadLen mnext <-
161− fillStreamBodyGetNext conn payloadOff lim tbq strm
162− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
163− maybeEnqueueNext out mnext
164− return off'
165−
166− output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do
167− -- Creating a push promise header
168− -- Frame id should be associated stream id from the client.
169− let !sid = streamNumber strm
170− len <- pushPromise pid sid ths off0
171− off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len
172− output out{ outputType = ORspn } off lim
173−
174− output _ _ _ = undefined -- never reach
175−
176− outputOrEnqueueAgain out off = E.handle resetStream $ do
177− state <- readIORef $ streamState strm
178− if isClosed state then
179− return off
180− else case out of
181− Output _ _ _ wait _ OWait -> do
182− -- Checking if all push are done.
183− let out' = out {
184− outputHook = return ()
185− , outputType = ORspn
186− }
187− forkAndEnqueueWhenReady wait outputQ out' mgr
188− return off
189− _ -> case mtbq of
190− Just tbq -> checkStreaming tbq
191− _ -> checkStreamWindowSize
192− where
193− strm = outputStream out
194− mtbq = outputMaybeTBQueue out
195− checkStreaming tbq = do
196− isEmpty <- atomically $ isEmptyTBQueue tbq
197− if isEmpty then do
198− forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr
199− return off
200− else
201− checkStreamWindowSize
202− checkStreamWindowSize = do
203− sws <- getStreamWindowSize strm
204− if sws == 0 then do
205− forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr
206− return off
207− else do
208− cws <- atomically $ readTVar connectionWindow -- not 0
209− let !lim = min cws sws
210− output out off lim
211− resetStream e = do
212− closed ctx strm (ResetByMe e)
213− let !rst = resetFrame InternalError $ streamNumber strm
214− enqueueControl controlQ $ CFrame rst
215− return off
216−
217− {-# INLINE flushN #-}
218− -- Flush the connection buffer to the socket, where the first 'n' bytes of
219− -- the buffer are filled.
220− flushN :: Int -> IO ()
221− flushN n = bufferIO connWriteBuffer n connSendAll
222−
223− headerContinue sid ths endOfStream off = do
224− let !offkv = off + frameHeaderLength
225− let !bufkv = connWriteBuffer `plusPtr` offkv
226− !limkv = connBufferSize - offkv
227− (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths
228− let flag0 = case hs of
229− [] -> setEndHeader defaultFlags
230− _ -> defaultFlags
231− flag = if endOfStream then setEndStream flag0 else flag0
232− let buf = connWriteBuffer `plusPtr` off
233− fillFrameHeader FrameHeaders kvlen sid flag buf
234− continue sid kvlen hs
235−
236− !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
237− !headerPayloadLim = connBufferSize - frameHeaderLength
238−
239− continue _ kvlen [] = return kvlen
240− continue sid kvlen ths = do
241− flushN $ kvlen + frameHeaderLength
242− -- Now off is 0
243− (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths
244− when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"
245− let flag = case ths' of
246− [] -> setEndHeader defaultFlags
247− _ -> defaultFlags
248− fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
249− continue sid kvlen' ths'
250−
251− {-# INLINE maybeEnqueueNext #-}
252− -- Re-enqueue the stream in the output queue.
253− maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()
254− maybeEnqueueNext _ Nothing = return ()
255− maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'
256− where
257− !out' = out { outputType = ONext next }
258−
259− {-# INLINE sendHeadersIfNecessary #-}
260− -- Send headers if there is not room for a 1-byte data frame, and return
261− -- the offset of the next frame's first header byte.
262− sendHeadersIfNecessary off
263− -- True if the connection buffer has room for a 1-byte data frame.
264− | off + frameHeaderLength < connBufferSize = return off
265− | otherwise = do
266− flushN off
267− return 0
268−
269− fillDataHeader strm@Stream{streamWindow,streamNumber}
270− off datPayloadLen mnext tell getH2D = do
271− -- Data frame header
272− mh2d <- getH2D
273− let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of
274− Nothing -> ([], True)
275− Just ts -> (ts, null ts)
276− !buf = connWriteBuffer `plusPtr` off
277− !off' = off + frameHeaderLength + datPayloadLen
278− !noMoreBody = isNothing mnext
279− flag | noMoreBody && noTrailers = setEndStream defaultFlags
280− | otherwise = defaultFlags
281− fillFrameHeader FrameData datPayloadLen streamNumber flag buf
282− off'' <- handleEndOfBody noMoreBody off' noTrailers trailers
283− atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)
284− atomically $ modifyTVar' streamWindow (subtract datPayloadLen)
285− return off''
286− where
287− handleTrailers True off0 _ = return off0
288− handleTrailers _ off0 trailers = do
289− (ths,_) <- toHeaderTable trailers
290− kvlen <- headerContinue streamNumber ths True off0
291− sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen
292− handleEndOfBody True off0 noTrailers trailers = do
293− off1 <- handleTrailers noTrailers off0 trailers
294− void tell
295− closed ctx strm Finished
296− return off1
297− handleEndOfBody False off0 _ _ = return off0
298−
299−
300− pushPromise pid sid ths off = do
301− let !offsid = off + frameHeaderLength
302− !bufsid = connWriteBuffer `plusPtr` offsid
303− poke32 bufsid $ fromIntegral sid
304− let !offkv = offsid + 4
305− !bufkv = connWriteBuffer `plusPtr` offkv
306− !limkv = connBufferSize - offkv
307− (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths
308− let !flag = setEndHeader defaultFlags -- No EndStream flag
309− !buf = connWriteBuffer `plusPtr` off
310− !len = kvlen + 4
311− fillFrameHeader FramePushPromise len pid flag buf
312− return len
313−
314− {-# INLINE fillFrameHeader #-}
315− fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf
316− where
317− hinfo = FrameHeader len flag sid
318−
319− {-# INLINE ignore #-}
320− ignore :: E.SomeException -> IO ()
321− ignore _ = return ()
322−
323−----------------------------------------------------------------
324−
325−{-
326−ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)
327−ResponseBuilder Status ResponseHeaders Builder
328−ResponseStream Status ResponseHeaders StreamingBody
329−ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response
330−-}
331−
332−fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next
333−fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}
334− _ off lim bb = do
335− let datBuf = connWriteBuffer `plusPtr` off
336− room = min (connBufferSize - off) lim
337− (len, signal) <- B.runBuilder bb datBuf room
338− return $ nextForBuilder len signal
339−
340−fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next
341−#ifdef WINDOWS
342−fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}
343− _ off lim path mpart = do
344− let datBuf = connWriteBuffer `plusPtr` off
345− room = min (connBufferSize - off) lim
346− (start, bytes) <- fileStartEnd path mpart
347− -- fixme: how to close Handle? GC does it at this moment.
348− hdl <- IO.openBinaryFile path IO.ReadMode
349− IO.hSeek hdl IO.AbsoluteSeek start
350− len <- IO.hGetBufSome hdl datBuf (mini room bytes)
351− let bytes' = bytes - fromIntegral len
352− -- fixme: connWriteBuffer connBufferSize
353− return $ nextForFile len hdl bytes' (return ())
354−#else
355−fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}
356− ii off lim path mpart = do
357− (mfd, refresh') <- getFd ii path
358− (fd, refresh) <- case mfd of
359− Nothing -> do
360− fd' <- openFile path
361− th <- T.register (timeoutManager ii) (closeFile fd')
362− return (fd', T.tickle th)
363− Just fd -> return (fd, refresh')
364− let datBuf = connWriteBuffer `plusPtr` off
365− room = min (connBufferSize - off) lim
366− (start, bytes) <- fileStartEnd path mpart
367− len <- positionRead fd datBuf (mini room bytes) start
368− refresh
369− let len' = fromIntegral len
370− return $ nextForFile len fd (start + len') (bytes - len') refresh
371−#endif
372−
373−fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)
374−fileStartEnd _ (Just part) =
375− return (filePartOffset part, filePartByteCount part)
376−fileStartEnd _ _ = error "fileStartEnd"
377−
378−----------------------------------------------------------------
379−
380−fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next
381−fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}
382− off lim sq strm = do
383− let datBuf = connWriteBuffer `plusPtr` off
384− room = min (connBufferSize - off) lim
385− (leftover, cont, len) <- runStreamBuilder datBuf room sq
386− return $ nextForStream sq strm leftover cont len
387−
388−----------------------------------------------------------------
389−
390−fillBufBuilder :: Leftover -> DynaNext
391−fillBufBuilder leftover buf0 siz0 lim = do
392− let payloadBuf = buf0 `plusPtr` frameHeaderLength
393− room = min (siz0 - frameHeaderLength) lim
394− case leftover of
395− LZero -> error "fillBufBuilder: LZero"
396− LOne writer -> do
397− (len, signal) <- writer payloadBuf room
398− getNext len signal
399− LTwo bs writer
400− | BS.length bs <= room -> do
401− buf1 <- copy payloadBuf bs
402− let len1 = BS.length bs
403− (len2, signal) <- writer buf1 (room - len1)
404− getNext (len1 + len2) signal
405− | otherwise -> do
406− let (bs1,bs2) = BS.splitAt room bs
407− void $ copy payloadBuf bs1
408− getNext room (B.Chunk bs2 writer)
409− where
410− getNext l s = return $ nextForBuilder l s
411−
412−nextForBuilder :: BytesFilled -> B.Next -> Next
413−nextForBuilder len B.Done
414− = Next len Nothing
415−nextForBuilder len (B.More _ writer)
416− = Next len $ Just (fillBufBuilder (LOne writer))
417−nextForBuilder len (B.Chunk bs writer)
418− = Next len $ Just (fillBufBuilder (LTwo bs writer))
419−
420−----------------------------------------------------------------
421−
422−runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence
423− -> IO (Leftover, Bool, BytesFilled)
424−runStreamBuilder buf0 room0 sq = loop buf0 room0 0
425− where
426− loop !buf !room !total = do
427− mbuilder <- atomically $ tryReadTBQueue sq
428− case mbuilder of
429− Nothing -> return (LZero, True, total)
430− Just (SBuilder builder) -> do
431− (len, signal) <- B.runBuilder builder buf room
432− let !total' = total + len
433− case signal of
434− B.Done -> loop (buf `plusPtr` len) (room - len) total'
435− B.More _ writer -> return (LOne writer, True, total')
436− B.Chunk bs writer -> return (LTwo bs writer, True, total')
437− Just SFlush -> return (LZero, True, total)
438− Just SFinish -> return (LZero, False, total)
439−
440−fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext
441−fillBufStream leftover0 sq strm buf0 siz0 lim0 = do
442− let payloadBuf = buf0 `plusPtr` frameHeaderLength
443− room0 = min (siz0 - frameHeaderLength) lim0
444− case leftover0 of
445− LZero -> do
446− (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq
447− getNext leftover cont len
448− LOne writer -> write writer payloadBuf room0 0
449− LTwo bs writer
450− | BS.length bs <= room0 -> do
451− buf1 <- copy payloadBuf bs
452− let len = BS.length bs
453− write writer buf1 (room0 - len) len
454− | otherwise -> do
455− let (bs1,bs2) = BS.splitAt room0 bs
456− void $ copy payloadBuf bs1
457− getNext (LTwo bs2 writer) True room0
458− where
459− getNext l b r = return $ nextForStream sq strm l b r
460− write writer1 buf room sofar = do
461− (len, signal) <- writer1 buf room
462− case signal of
463− B.Done -> do
464− (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq
465− let !total = sofar + len + extra
466− getNext leftover cont total
467− B.More _ writer -> do
468− let !total = sofar + len
469− getNext (LOne writer) True total
470− B.Chunk bs writer -> do
471− let !total = sofar + len
472− getNext (LTwo bs writer) True total
473−
474−nextForStream :: TBQueue Sequence -> Stream
475− -> Leftover -> Bool -> BytesFilled
476− -> Next
477−nextForStream _ _ _ False len = Next len Nothing
478−nextForStream sq strm leftOrZero True len =
479− Next len $ Just (fillBufStream leftOrZero sq strm)
480−
481−----------------------------------------------------------------
482−
483−#ifdef WINDOWS
484−fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext
485−fillBufFile h bytes refresh buf siz lim = do
486− let payloadBuf = buf `plusPtr` frameHeaderLength
487− room = min (siz - frameHeaderLength) lim
488− len <- IO.hGetBufSome h payloadBuf room
489− refresh
490− let bytes' = bytes - fromIntegral len
491− return $ nextForFile len h bytes' refresh
492−
493−nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next
494−nextForFile 0 _ _ _ = Next 0 Nothing
495−nextForFile len _ 0 _ = Next len Nothing
496−nextForFile len h bytes refresh =
497− Next len $ Just (fillBufFile h bytes refresh)
498−#else
499−fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext
500−fillBufFile fd start bytes refresh buf siz lim = do
501− let payloadBuf = buf `plusPtr` frameHeaderLength
502− room = min (siz - frameHeaderLength) lim
503− len <- positionRead fd payloadBuf (mini room bytes) start
504− let len' = fromIntegral len
505− refresh
506− return $ nextForFile len fd (start + len') (bytes - len') refresh
507−
508−nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next
509−nextForFile 0 _ _ _ _ = Next 0 Nothing
510−nextForFile len _ _ 0 _ = Next len Nothing
511−nextForFile len fd start bytes refresh =
512− Next len $ Just (fillBufFile fd start bytes refresh)
513−#endif
514−
515−{-# INLINE mini #-}
516−mini :: Int -> Integer -> Int
517−mini i n
518− | fromIntegral i < n = i
519− | otherwise = fromIntegral n
520−
521−
522−----------------------------------------------------------------
523−
524−poke32 :: Ptr Word8 -> Word32 -> IO ()
525−poke32 ptr i = do
526− poke ptr w0
527− poke8 ptr 1 w1
528− poke8 ptr 2 w2
529− poke8 ptr 3 w3
530− where
531− w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)
532− w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)
533− w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)
534− w3 = fromIntegral (i .&. 0xff)
535− poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()
536− poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w