7dc82b9 · typeable/wai

wai/Network/Wai/HTTP2.hs+8−4

compare with master

unifiedsplit

@@ -1,8 +1,9 @@

1module Network.Wai.HTTP2

2 ( Http2Application

3− , Response(..)

3+ , Response

4 , Trailers

5 , responseStatus

6+ , responseStream

6 , responseHeaders

7 , responseHeaders

7 ) where

8 ) where

8

9

@@ -20,10 +21,13 @@ type Http2Application = Request -> (Response -> IO ()) -> IO Trailers

20

21

21type StreamingBody = (Builder -> IO ()) -> IO () -> IO ()

22type StreamingBody = (Builder -> IO ()) -> IO () -> IO ()

22

23

23−data Response = ResponseStream H.Status H.ResponseHeaders StreamingBody

24+type Response = (H.Status, H.ResponseHeaders, StreamingBody)

24

25

25responseStatus :: Response -> H.Status

26responseStatus :: Response -> H.Status

26−responseStatus (ResponseStream s _ _) = s

27+responseStatus (s, _, _) = s

27

28

28responseHeaders :: Response -> H.ResponseHeaders

29responseHeaders :: Response -> H.ResponseHeaders

29−responseHeaders (ResponseStream _ h _) = h

30+responseHeaders (_, h, _) = h

31+

32+responseStream :: H.Status -> H.ResponseHeaders -> StreamingBody -> Response

33+responseStream = (,,)

warp/Network/Wai/Handler/Warp/HTTP2.hs+1−2

@@ -17,7 +17,6 @@ import Network.HTTP2

17import Network.Socket (SockAddr)

18

19import Network.Wai (Application, responseToStream)

20−import Network.Wai.HTTP2 (Response(..))

21import Network.Wai.HTTP2 (Http2Application)

20import Network.Wai.HTTP2 (Http2Application)

22import Network.Wai.Internal (ResponseReceived(..))

21import Network.Wai.Internal (ResponseReceived(..))

23import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

22import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

@@ -80,5 +79,5 @@ goaway Connection{..} etype debugmsg = connSendAll bytestream

80promoteApplication :: Application -> Http2Application

79promoteApplication :: Application -> Http2Application

81promoteApplication app req respond = [] <$ app req respond'

80promoteApplication app req respond = [] <$ app req respond'

82 where

81 where

83− respond' r = ResponseReceived <$ (withBody $ respond . ResponseStream s h)

82+ respond' r = ResponseReceived <$ (withBody $ \b -> respond (s, h, b))

84 where (s, h, withBody) = responseToStream r

83 where (s, h, withBody) = responseToStream r

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+7−8

@@ -13,24 +13,23 @@ import Data.IORef (readIORef, writeIORef)

13import Network.HPACK

14import qualified Network.HTTP.Types as H

15import Network.HTTP2

16−import Network.Wai.HTTP2 (Trailers, Response, responseStatus, responseHeaders)

16+import Network.Wai.HTTP2 (Trailers)

17import Network.Wai.Handler.Warp.HTTP2.Types

18import Network.Wai.Handler.Warp.Header

19import Network.Wai.Handler.Warp.Response

20import qualified Network.Wai.Handler.Warp.Settings as S

21import Network.Wai.Handler.Warp.Types

22

23−hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response

23+hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> H.Status

24− -> IO Builder

24+ -> H.ResponseHeaders -> IO Builder

25−hpackEncodeHeader ctx ii settings rsp = do

25+hpackEncodeHeader ctx ii settings s h = do

26− hdr1 <- addServerAndDate hdr0

26+ hdr1 <- addServerAndDate h

27 let hdr2 = (":status", status) : map (first foldedCase) hdr1

28 hpackEncodeRawHeaders ctx hdr2

29 where

30− hdr0 = responseHeaders rsp

31− status = B8.pack $ show $ H.statusCode $ responseStatus rsp

30+ status = B8.pack $ show $ H.statusCode $ s

32 dc = dateCacher ii

31 dc = dateCacher ii

33− rspidxhdr = indexResponseHeader hdr0

32+ rspidxhdr = indexResponseHeader h

34 defServer = S.settingsServerName settings

33 defServer = S.settingsServerName settings

35 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

34 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

36

35

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+2−2

@@ -81,12 +81,12 @@ frameSender ctx@Context{outputQ,connectionWindow}

81 switch (OFrame frame) = do

82 connSendAll frame

83 loop

84− switch (OResponse strm rsp aux) = do

84+ switch (OResponse strm s h aux) = do

85 unlessClosed ctx conn strm $ do

86 lim <- getWindowSize connectionWindow (streamWindow strm)

87 -- Header frame and Continuation frame

88 let sid = streamNumber strm

89− builder <- hpackEncodeHeader ctx ii settings rsp

89+ builder <- hpackEncodeHeader ctx ii settings s h

90 len <- headerContinue sid builder False

91 let total = len + frameHeaderLength

92 case aux of

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+5−5

@@ -18,7 +18,7 @@ import Data.IntMap.Strict (IntMap, IntMap)

18import qualified Data.IntMap.Strict as M

19import qualified Network.HTTP.Types as H

20import Network.Wai (Request)

21−import Network.Wai.HTTP2 (Trailers, Response)

21+import Network.Wai.HTTP2 (Trailers)

22import Network.Wai.Handler.Warp.IORef

23import Network.Wai.Handler.Warp.Types

24

@@ -66,7 +66,7 @@ data Output = OFinish

66 -- ^ Send a goaway frame and terminate the connection.

67 | OFrame ByteString

68 -- ^ Send an entire pre-encoded frame.

69− | OResponse Stream Response Aux

69+ | OResponse Stream H.Status H.ResponseHeaders Aux

70 -- ^ Send the headers and as much of the response as is immediately

71 -- available.

72 | ONext Stream DynaNext

@@ -75,9 +75,9 @@ data Output = OFinish

75 -- ^ Send a series of trailers in header and continuation frames.

76

77outputStream :: Output -> Stream

78−outputStream (OResponse strm _ _) = strm

78+outputStream (OResponse strm _ _ _) = strm

79−outputStream (ONext strm _) = strm

79+outputStream (ONext strm _) = strm

80−outputStream _ = error "outputStream"

80+outputStream _ = error "outputStream"

81

82----------------------------------------------------------------

83

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+25−27

@@ -20,7 +20,7 @@ import Control.Monad (void, when)

20import Data.Typeable

21import Network.HTTP2

22import Network.HTTP2.Priority

23−import Network.Wai.HTTP2 (Http2Application, Response(..))

23+import Network.Wai.HTTP2 (Http2Application, Response)

24import Network.Wai hiding (Response, responseStatus)

25import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

26import Network.Wai.Handler.Warp.HTTP2.Manager

@@ -41,32 +41,30 @@ type Responder = ThreadContinue -> T.Handle -> Stream ->

41-- They also pass 'Response's from 'Http2Application's to this function.

42-- This function enqueues commands for the HTTP/2 sender.

43response :: Context -> Manager -> Responder

44−response Context{outputQ} mgr tconf th strm sq rsp = do

44+response Context{outputQ} mgr tconf th strm sq (s, h, strmbdy) = do

45− case rsp of

46− ResponseStream _ _ strmbdy -> do

47− -- TODO(awpr)r HEAD requests will still stream.

45+ -- TODO(awpr)r HEAD requests will still stream.

48− --

46+ --

49− -- We must not exit this WAI application.

47+ -- We must not exit this WAI application.

50− -- If the application exits, streaming would be also closed.

48+ -- If the application exits, streaming would be also closed.

51− -- So, this work occupies this thread.

49+ -- So, this work occupies this thread.

52− --

50+ --

53− -- We need to increase the number of workers.

51+ -- We need to increase the number of workers.

54− myThreadId >>= replaceWithAction mgr

52+ myThreadId >>= replaceWithAction mgr

55− -- After this work, this thread stops to decease

53+ -- After this work, this thread stops to decease

56− -- the number of workers.

54+ -- the number of workers.

57− setThreadContinue tconf False

55+ setThreadContinue tconf False

58− tvar <- newTVarIO SyncNone

56+ tvar <- newTVarIO SyncNone

59− let out = OResponse strm rsp (Persist sq tvar)

57+ let out = OResponse strm s h (Persist sq tvar)

60− -- Since we must not enqueue an empty queue to the priority

58+ -- Since we must not enqueue an empty queue to the priority

61− -- queue, we spawn a thread to ensure that the designated

59+ -- queue, we spawn a thread to ensure that the designated

62− -- queue is not empty.

60+ -- queue is not empty.

63− void $ forkIO $ waiter tvar sq strm outputQ

61+ void $ forkIO $ waiter tvar sq strm outputQ

64− atomically $ writeTVar tvar (SyncNext out)

62+ atomically $ writeTVar tvar (SyncNext out)

65− let push b = do

63+ let push b = do

66− atomically $ writeTBQueue sq (SBuilder b)

64+ atomically $ writeTBQueue sq (SBuilder b)

67− T.tickle th

65+ T.tickle th

68− flush = atomically $ writeTBQueue sq SFlush

66+ flush = atomically $ writeTBQueue sq SFlush

69− strmbdy push flush

67+ strmbdy push flush

70

68

71data Break = Break deriving (Show, Typeable)

69data Break = Break deriving (Show, Typeable)

72

70