git.iko.soy/typeable/wai
on master help sign in
Add 'pushResponder' and real 'PushPromise' type
commit3c420e1fd417533ded2f2bfa96e57b3f801c5e3f authorAndrew Pritchard <awpr@google.com> dateMon 3 Aug 2015, 13:57 (11 years ago) parent6fa930b
3 files changed+49−17
compare with master
unifiedsplit
wai/Network/Wai/HTTP2.hs+22−12 warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+2−3 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+25−2
wai/Network/Wai/HTTP2.hs+22−12
@@ -1,17 +1,20 @@
1−{-# LANGUAGE EmptyCase, EmptyDataDecls, RankNTypes #-}
1+{-# LANGUAGE OverloadedStrings, RankNTypes #-}
22module Network.Wai.HTTP2
33 ( Http2Application
4− , PushPromise
4+ , PushPromise(..)
55 , Responder
66 , Response
77 , Trailers
8− , absurd
98 , responseStatus
109 , responseStream
1110 , responseHeaders
11+ , promiseHeaders
1212 ) where
1313
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)
1518import qualified Network.HTTP.Types as H
1619
1720import qualified Network.Wai.Internal as H1 (Request)
@@ -21,14 +24,13 @@ import qualified Network.Wai.Internal as H1 (Request)
2124type Trailers = [H.Header]
2225
2326-- | The synthesized request and headers of a pushed stream.
24−-- TODO(awpr): implement for real.
25−data PushPromise
26−
27−-- 'PushPromise' is currently uninhabited, which proves the caller cannot use
28−-- 'pushPromise'. This discharges the obligation to implement any function
29−-- taking a 'PushPromise'.
30−absurd :: PushPromise -> a
31−absurd p = case p of {}
27+data PushPromise = PushPromise
28+ { promisedMethod :: H.Method
29+ , promisedPath :: ByteString
30+ , promisedAuthority :: ByteString
31+ , promisedScheme :: ByteString
32+ , promisedHeader :: H.RequestHeaders
33+ }
3234
3335-- | The type of an HTTP\/2 request: a normal HTTP request and an action to
3436-- push streams associated with this request.
@@ -51,3 +53,11 @@ responseHeaders (_, h, _) = h
5153
5254responseStream :: H.Status -> H.ResponseHeaders -> Body a -> Response a
5355responseStream = (,,)
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
1818import qualified Network.HTTP.Types as H
1919import Network.HTTP2
2020import Network.HTTP2.Priority
21−import Network.Wai.HTTP2 (Trailers, absurd)
21+import Network.Wai.HTTP2 (Trailers, promiseHeaders)
2222import Network.Wai.Handler.Warp.Buffer
2323import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
2424import Network.Wai.Handler.Warp.HTTP2.HPACK
@@ -101,12 +101,11 @@ frameSender ctx@Context{outputQ,connectionWindow}
101101 unlessClosed ctx conn oldStrm $ do
102102 lim <- getWindowSize connectionWindow (streamWindow strm)
103103 -- Write and send the promise.
104− builder <- hpackEncodeCIHeaders ctx $ absurd push
104+ builder <- hpackEncodeCIHeaders ctx $ promiseHeaders push
105105 off <- pushContinue (streamNumber oldStrm) (streamNumber strm) builder
106106 flushN $ off + frameHeaderLength
107107 -- TODO(awpr): refactor sendResponse to be able to handle non-zero
108108 -- initial offsets and use that to potentially avoid the extra syscall.
109−
110109 sendResponse strm s h aux lim
111110 loop
112111 switch (OTrailers strm []) = do
warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+25−2
@@ -22,7 +22,7 @@ import Data.Typeable
2222import qualified Network.HTTP.Types as H
2323import Network.HTTP2
2424import Network.HTTP2.Priority
25−import Network.Wai.HTTP2 (Http2Application, Responder, Response, absurd)
25+import Network.Wai.HTTP2 (Http2Application, PushPromise, Responder, Response)
2626import Network.Wai hiding (Response, responseStatus)
2727import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
2828import Network.Wai.Handler.Warp.HTTP2.Manager
@@ -92,6 +92,29 @@ cleanupStream ctx@Context{outputQ} set strm req me = do
9292 Nothing -> return ()
9393 Just e -> S.settingsOnException set req e
9494
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+
95118data Break = Break deriving (Show, Typeable)
96119
97120instance Exception Break
@@ -118,7 +141,7 @@ worker ctx@Context{inputQ} set tm app respond = do
118141 setStreamInfo sinfo strm req
119142 T.resume th
120143 T.tickle th
121− let responder = app (req, flip (const absurd))
144+ let responder = app (req, pushResponder ctx set strm)
122145 runResponder responder (respond tcont) (T.tickle th) strm
123146 cont1 <- case ex of
124147 Right () -> return True