3c420e1 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Add 'pushResponder' and real 'PushPromise' type

3c420e1Andrew Pritchard11 years ago

wai/Network/Wai/HTTP2.hs+22−12

compare with master

unifiedsplit

@@ -1,17 +1,20 @@

1−{-# LANGUAGE EmptyCase, EmptyDataDecls, RankNTypes #-}

1+{-# LANGUAGE OverloadedStrings, RankNTypes #-}

2module Network.Wai.HTTP2

3 ( Http2Application

4− , PushPromise

4+ , PushPromise(..)

5 , Responder

6 , Response

7 , Trailers

8− , absurd

9 , responseStatus

8 , responseStatus

10 , responseStream

9 , responseStream

11 , responseHeaders

10 , responseHeaders

11+ , promiseHeaders

12 ) where

14−import Blaze.ByteString.Builder (Builder)

14+import Data.ByteString (ByteString)

15+import qualified Data.ByteString.Lazy as L

16+

17+import Data.ByteString.Builder (Builder)

15import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

17import qualified Network.Wai.Internal as H1 (Request)

20import qualified Network.Wai.Internal as H1 (Request)

@@ -21,14 +24,13 @@ import qualified Network.Wai.Internal as H1 (Request)

21type Trailers = [H.Header]

24type Trailers = [H.Header]

23-- | The synthesized request and headers of a pushed stream.

26-- | The synthesized request and headers of a pushed stream.

24−-- TODO(awpr): implement for real.

25−data PushPromise

27+data PushPromise = PushPromise

26−

28+ { promisedMethod :: H.Method

27−-- 'PushPromise' is currently uninhabited, which proves the caller cannot use

29+ , promisedPath :: ByteString

28−-- 'pushPromise'. This discharges the obligation to implement any function

30+ , promisedAuthority :: ByteString

29−-- taking a 'PushPromise'.

31+ , promisedScheme :: ByteString

30−absurd :: PushPromise -> a

32+ , promisedHeader :: H.RequestHeaders

31−absurd p = case p of {}

33+ }

33-- | The type of an HTTP\/2 request: a normal HTTP request and an action to

35-- | The type of an HTTP\/2 request: a normal HTTP request and an action to

34-- push streams associated with this request.

36-- push streams associated with this request.

@@ -51,3 +53,11 @@ responseHeaders (_, h, _) = h

52responseStream :: H.Status -> H.ResponseHeaders -> Body a -> Response a

54responseStream :: H.Status -> H.ResponseHeaders -> Body a -> Response a

53responseStream = (,,)

55responseStream = (,,)

56+

57+promiseHeaders :: PushPromise -> H.RequestHeaders

58+promiseHeaders p =

59+ [ (":method", promisedMethod p)

60+ , (":path", promisedPath p)

61+ , (":authority", promisedAuthority p)

62+ , (":scheme", promisedScheme p)

63+ ] ++ promisedHeader p

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

@@ -18,7 +18,7 @@ import Foreign.Ptr

18import qualified Network.HTTP.Types as H

19import Network.HTTP2

20import Network.HTTP2.Priority

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

21+import Network.Wai.HTTP2 (Trailers, promiseHeaders)

22import Network.Wai.Handler.Warp.Buffer

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

24import Network.Wai.Handler.Warp.HTTP2.HPACK

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

101 unlessClosed ctx conn oldStrm $ do

102 lim <- getWindowSize connectionWindow (streamWindow strm)

103 -- Write and send the promise.

104− builder <- hpackEncodeCIHeaders ctx $ absurd push

104+ builder <- hpackEncodeCIHeaders ctx $ promiseHeaders push

105 off <- pushContinue (streamNumber oldStrm) (streamNumber strm) builder

106 flushN $ off + frameHeaderLength

107 -- TODO(awpr): refactor sendResponse to be able to handle non-zero

108 -- initial offsets and use that to potentially avoid the extra syscall.

109−

110 sendResponse strm s h aux lim

109 sendResponse strm s h aux lim

111 loop

110 loop

112 switch (OTrailers strm []) = do

111 switch (OTrailers strm []) = do

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

@@ -22,7 +22,7 @@ import Data.Typeable

22import qualified Network.HTTP.Types as H

23import Network.HTTP2

24import Network.HTTP2.Priority

25−import Network.Wai.HTTP2 (Http2Application, Responder, Response, absurd)

25+import Network.Wai.HTTP2 (Http2Application, PushPromise, Responder, Response)

26import Network.Wai hiding (Response, responseStatus)

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

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

@@ -92,6 +92,29 @@ cleanupStream ctx@Context{outputQ} set strm req me = do

92 Nothing -> return ()

93 Just e -> S.settingsOnException set req e

95+pushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO ()

96+pushResponder ctx set strm promise responder = do

97+ let Context{ http2settings

98+ , nextPushStreamId

99+ , streamTable

100+ } = ctx

101+ -- Claim the next outgoing stream.

102+ newSid <- atomicModifyIORef nextPushStreamId $ \sid -> (sid+2, sid)

103+ ws <- initialWindowSize <$> readIORef http2settings

104+

105+ newStrm <- newStream newSid ws

106+ opened ctx newStrm

107+ insert streamTable newSid newStrm

108+

109+ let pri = Priority False (streamNumber strm) 16

110+ mkOutput = OPush strm promise

111+ tickle = return ()

112+ respond = runStream ctx mkOutput

113+

114+ -- TODO(awpr): synthesize a Request for 'settingsOnException'?

115+ runResponder responder respond tickle newStrm `E.catch`

116+ (cleanupStream ctx set strm Nothing . Just)

117+

95data Break = Break deriving (Show, Typeable)

118data Break = Break deriving (Show, Typeable)

119

97instance Exception Break

120instance Exception Break

@@ -118,7 +141,7 @@ worker ctx@Context{inputQ} set tm app respond = do

118 setStreamInfo sinfo strm req

141 setStreamInfo sinfo strm req

119 T.resume th

142 T.resume th

120 T.tickle th

143 T.tickle th

121− let responder = app (req, flip (const absurd))

144+ let responder = app (req, pushResponder ctx set strm)

122 runResponder responder (respond tcont) (T.tickle th) strm

145 runResponder responder (respond tcont) (T.tickle th) strm

123 cont1 <- case ex of

146 cont1 <- case ex of

124 Right () -> return True

147 Right () -> return True