72b6292 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

defining APIs for HTTP/2 trailers.

72b6292Kazu Yamamoto10 years ago

warp/Network/Wai/Handler/Warp.hs+3−1

compare with master

unifiedsplit

@@ -104,9 +104,11 @@ module Network.Wai.Handler.Warp (

104 -- ** HTTP2 data

105 , HTTP2Data

106 , http2dataPushPromise

107+ , http2dataTrailers

107 , defaultHTTP2Data

108 , defaultHTTP2Data

108 , getHTTP2Data

109 , getHTTP2Data

109 , setHTTP2Data

110 , setHTTP2Data

111+ , modifyHTTP2Data

110 -- ** Push promise

112 -- ** Push promise

111 , PushPromise

113 , PushPromise

112 , promisedPath

114 , promisedPath

@@ -129,7 +131,7 @@ import Network.Wai.Handler.Warp.Request

129import Network.Wai.Handler.Warp.Response (warpVersion)

131import Network.Wai.Handler.Warp.Response (warpVersion)

130import Network.Wai.Handler.Warp.Run

132import Network.Wai.Handler.Warp.Run

131import Network.Wai.Handler.Warp.Settings

133import Network.Wai.Handler.Warp.Settings

132−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data)

134+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

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

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

134import Network.Wai.Handler.Warp.Timeout

136import Network.Wai.Handler.Warp.Timeout

135import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

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

@@ -6,6 +6,7 @@ module Network.Wai.Handler.Warp.HTTP2.Request (

6 , MkReq

7 , getHTTP2Data

8 , setHTTP2Data

9+ , modifyHTTP2Data

9 ) where

10 ) where

11import Control.Applicative ((<|>))

12import Control.Applicative ((<|>))

@@ -83,6 +84,7 @@ mkRequest' ii1 settings addr ref (reqths,reqvt) body = return (req,ii)

83 $ Vault.insert getFileInfoKey (getFileInfo ii)

84 $ Vault.insert getFileInfoKey (getFileInfo ii)

84 $ Vault.insert getHTTP2DataKey (readIORef ref)

85 $ Vault.insert getHTTP2DataKey (readIORef ref)

85 $ Vault.insert setHTTP2DataKey (writeIORef ref)

86 $ Vault.insert setHTTP2DataKey (writeIORef ref)

87+ $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

86 Vault.empty

88 Vault.empty

88getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

90getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

@@ -103,10 +105,23 @@ setHTTP2DataKey = unsafePerformIO Vault.newKey

103{-# NOINLINE setHTTP2Data #-}

105{-# NOINLINE setHTTP2Data #-}

104

106

105-- | Setting 'HTTP2Data' through vault of the request.

107-- | Setting 'HTTP2Data' through vault of the request.

106−-- 'Middleware' should use this.

108+-- 'Application' or 'Middleware' should use this.

107--

109--

108-- Since: 3.2.7

110-- Since: 3.2.7

109setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()

111setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()

110setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of

112setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of

111 Nothing -> return ()

113 Nothing -> return ()

112 Just setter -> setter mh2d

114 Just setter -> setter mh2d

115+

116+modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

117+modifyHTTP2DataKey = unsafePerformIO Vault.newKey

118+{-# NOINLINE modifyHTTP2Data #-}

119+

120+-- | Modifying 'HTTP2Data' through vault of the request.

121+-- 'Application' or 'Middleware' should use this.

122+--

123+-- Since: 3.2.8

124+modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()

125+modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of

126+ Nothing -> return ()

127+ Just modify -> modify func

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

@@ -18,7 +18,7 @@ import Data.Maybe (isNothing)

18import Data.Word (Word8, Word32)

19import Foreign.Ptr (Ptr, plusPtr)

20import Foreign.Storable (poke)

21−import Network.HPACK (setLimitForEncoding)

21+import Network.HPACK (setLimitForEncoding, toHeaderTable)

22import Network.HTTP2

23import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)

24import Network.Wai

@@ -122,16 +122,16 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

122 Nothing -> return ()

123 Just siz -> setLimitForEncoding siz encodeDynamicTable

124

125− output out@(Output strm _ _ tell (ONext curr)) off0 lim = do

125+ output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do

126 -- Data frame payload

127 let !buf = connWriteBuffer `plusPtr` off0

128 !siz = connBufferSize - off0

129 Next datPayloadLen mnext <- curr buf siz lim

130− off <- fillDataHeader strm off0 datPayloadLen mnext tell

130+ off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D

131 maybeEnqueueNext out mnext

132 return off

133

134− output out@(Output strm rspn ii tell ORspn) off0 lim = do

134+ output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do

135 -- Header frame and Continuation frame

136 let !sid = streamNumber strm

137 !endOfStream = case rspn of

@@ -149,7 +149,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

149 let payloadOff = off + frameHeaderLength

150 Next datPayloadLen mnext <-

151 fillFileBodyGetNext conn ii payloadOff lim path mpart

152− off' <- fillDataHeader strm off datPayloadLen mnext tell

152+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

153 maybeEnqueueNext out mnext

154 return off'

155 RspnBuilder _ _ builder -> do

@@ -157,24 +157,24 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

157 let payloadOff = off + frameHeaderLength

158 Next datPayloadLen mnext <-

159 fillBuilderBodyGetNext conn ii payloadOff lim builder

160− off' <- fillDataHeader strm off datPayloadLen mnext tell

160+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

161 maybeEnqueueNext out mnext

162 return off'

163 RspnStreaming _ _ tbq -> do

164 let payloadOff = off + frameHeaderLength

165 Next datPayloadLen mnext <-

166 fillStreamBodyGetNext conn payloadOff lim tbq strm

167− off' <- fillDataHeader strm off datPayloadLen mnext tell

167+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

168 maybeEnqueueNext out mnext

169 return off'

170

171− output (Output strm rspn ii tell (OPush ths pid)) off0 lim = do

171+ output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do

172 -- Creating a push promise header

173 -- Frame id should be associated stream id from the client.

174 let !sid = streamNumber strm

175 len <- pushPromise pid sid ths off0

176 off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len

177− output (Output strm rspn ii tell ORspn) off lim

177+ output out{ outputType = ORspn } off lim

178

179 output _ _ _ = undefined -- never reach

180

@@ -183,9 +183,12 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

183 if isClosed state then

184 return off

185 else case out of

186− Output strm' rsp ii wait OWait -> do

186+ Output _ _ _ wait _ OWait -> do

187 -- Checking if all push are done.

188− let out' = Output strm' rsp ii (return ()) ORspn

188+ let out' = out {

189+ outputHook = return ()

190+ , outputType = ORspn

191+ }

189 forkAndEnqueueWhenReady wait outputQ out' mgr

192 forkAndEnqueueWhenReady wait outputQ out' mgr

190 return off

193 return off

191 _ -> case mtbq of

194 _ -> case mtbq of

@@ -268,21 +271,36 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

268 flushN off

271 flushN off

269 return 0

272 return 0

270

273

274+ fillDataHeader strm@Stream{streamWindow,streamNumber}

271− fillDataHeader strm off datPayloadLen mnext tell = do

275+ off datPayloadLen mnext tell getH2D = do

272 -- Data frame header

276 -- Data frame header

273− let !sid = streamNumber strm

277+ mh2d <- getH2D

278+ let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of

279+ Nothing -> ([], True)

280+ Just ts -> (ts, null ts)

274 !buf = connWriteBuffer `plusPtr` off

281 !buf = connWriteBuffer `plusPtr` off

275 !off' = off + frameHeaderLength + datPayloadLen

282 !off' = off + frameHeaderLength + datPayloadLen

276− !done = isNothing mnext

283+ !noMoreBody = isNothing mnext

277− flag | done = setEndStream defaultFlags

284+ flag | noMoreBody && noTrailers = setEndStream defaultFlags

278− | otherwise = defaultFlags

285+ | otherwise = defaultFlags

279− fillFrameHeader FrameData datPayloadLen sid flag buf

286+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf

280− when done $ do

287+ off'' <- handleEndOfBody noMoreBody off' noTrailers trailers

288+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

289+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)

290+ return off''

291+ where

292+ handleTrailers True off0 _ = return off0

293+ handleTrailers _ off0 trailers = do

294+ (ths,_) <- toHeaderTable trailers

295+ kvlen <- headerContinue streamNumber ths True off0

296+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

297+ handleEndOfBody True off0 noTrailers trailers = do

298+ off1 <- handleTrailers noTrailers off0 trailers

281 void $ tell

299 void $ tell

282 closed ctx strm Finished

300 closed ctx strm Finished

283− atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

301+ return off1

284− atomically $ modifyTVar' (streamWindow strm) (subtract datPayloadLen)

302+ handleEndOfBody False off0 _ _ = return off0

285− return off'

303+

286

304

287 pushPromise pid sid ths off = do

305 pushPromise pid sid ths off = do

288 let !offsid = off + frameHeaderLength

306 let !offsid = off + frameHeaderLength

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

@@ -73,6 +73,7 @@ data Output = Output {

73 , outputRspn :: !Rspn

74 , outputII :: !InternalInfo

75 , outputHook :: IO () -- OPush: wait for done, O*: telling done

76+ , outputH2Data :: IO (Maybe HTTP2Data)

76 , outputType :: !OutputType

77 , outputType :: !OutputType

77 }

78 }

@@ -82,8 +83,8 @@ data OutputType = ORspn

82 | ONext !DynaNext

83 | ONext !DynaNext

84outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)

85outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)

85−outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _) = Just tbq

86+outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq

86−outputMaybeTBQueue _ = Nothing

87+outputMaybeTBQueue _ = Nothing

88data Control = CFinish

89data Control = CFinish

89 | CGoaway !ByteString

90 | CGoaway !ByteString

@@ -281,18 +282,20 @@ enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl

281-- | HTTP/2 specific data.

282-- | HTTP/2 specific data.

282--

283--

283-- Since: 3.2.7

284-- Since: 3.2.7

284−newtype HTTP2Data = HTTP2Data {

285+data HTTP2Data = HTTP2Data {

285 -- | Accessor for 'PushPromise' in 'HTTP2Data'.

286 -- | Accessor for 'PushPromise' in 'HTTP2Data'.

286 --

287 --

287 -- Since: 3.2.7

288 -- Since: 3.2.7

288 http2dataPushPromise :: [PushPromise]

289 http2dataPushPromise :: [PushPromise]

290+ -- Since: 3.2.8

291+ , http2dataTrailers :: H.ResponseHeaders

289 } deriving (Eq,Show)

292 } deriving (Eq,Show)

290

293

291-- | Default HTTP/2 specific data.

294-- | Default HTTP/2 specific data.

292--

295--

293-- Since: 3.2.7

296-- Since: 3.2.7

294defaultHTTP2Data :: HTTP2Data

297defaultHTTP2Data :: HTTP2Data

295−defaultHTTP2Data = HTTP2Data []

298+defaultHTTP2Data = HTTP2Data [] []

296

299

297-- | HTTP/2 push promise or sever push.

300-- | HTTP/2 push promise or sever push.

298--

301--

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

@@ -81,6 +81,7 @@ pushStream ctx@Context{http2settings,outputQ,streamTable}

81 waiter lim tvar = atomically $ do

82 n <- readTVar tvar

83 check (n >= lim)

84+ !h2data = getHTTP2Data req

84 push _ [] !n = return (n :: Int)

85 push _ [] !n = return (n :: Int)

85 push tvar (pp:pps) !n = do

86 push tvar (pp:pps) !n = do

86 let !file = promisedFile pp

87 let !file = promisedFile pp

@@ -111,7 +112,7 @@ pushStream ctx@Context{http2settings,outputQ,streamTable}

111 addContentHeadersForFilePart ths0 part

112 addContentHeadersForFilePart ths0 part

112 pushLogger req path size

113 pushLogger req path size

113 let !ot = OPush promisedRequest pid

114 let !ot = OPush promisedRequest pid

114− !out = Output strm rsp ii (increment tvar) ot

115+ !out = Output strm rsp ii (increment tvar) h2data ot

115 enqueueOutput outputQ out

116 enqueueOutput outputQ out

116 push tvar pps (n + 1)

117 push tvar pps (n + 1)

117

118

@@ -145,6 +146,7 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

145 !logger = S.settingsLogger settings

146 !logger = S.settingsLogger settings

146 !th = threadHandle ii

147 !th = threadHandle ii

147 sid = streamNumber strm

148 sid = streamNumber strm

149+ !h2data = getHTTP2Data req

148

150

149 -- Ideally, log messages should be written when responses are

151 -- Ideally, log messages should be written when responses are

150 -- actually sent. But there is no way to keep good memory usage

152 -- actually sent. But there is no way to keep good memory usage

@@ -158,7 +160,7 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

158 logger req s Nothing

160 logger req s Nothing

159 setThreadContinue tconf True

161 setThreadContinue tconf True

160 let !rspn = RspnNobody s tbl

162 let !rspn = RspnNobody s tbl

161− !out = Output strm rspn ii (return ()) ORspn

163+ !out = Output strm rspn ii (return ()) h2data ORspn

162 enqueueOutput outputQ out

164 enqueueOutput outputQ out

163 return ResponseReceived

165 return ResponseReceived

164

166

@@ -167,7 +169,7 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

167 setThreadContinue tconf True

169 setThreadContinue tconf True

168 tbl <- toHeaderTable hs0

170 tbl <- toHeaderTable hs0

169 let !rspn = RspnBuilder s tbl bdy

171 let !rspn = RspnBuilder s tbl bdy

170− !out = Output strm rspn ii tell rspnOrWait

172+ !out = Output strm rspn ii tell h2data rspnOrWait

171 enqueueOutput outputQ out

173 enqueueOutput outputQ out

172 return ResponseReceived

174 return ResponseReceived

173

175

@@ -193,7 +195,7 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

193 logger req s (filePartByteCount <$> mpart)

195 logger req s (filePartByteCount <$> mpart)

194 setThreadContinue tconf True

196 setThreadContinue tconf True

195 let !rspn = RspnFile s tbl path mpart

197 let !rspn = RspnFile s tbl path mpart

196− !out = Output strm rspn ii tell rspnOrWait

198+ !out = Output strm rspn ii tell h2data rspnOrWait

197 enqueueOutput outputQ out

199 enqueueOutput outputQ out

198 return ResponseReceived

200 return ResponseReceived

199

201

@@ -219,7 +221,7 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

219 tbq <- newTBQueueIO 10 -- fixme: hard coding: 10

221 tbq <- newTBQueueIO 10 -- fixme: hard coding: 10

220 tbl <- toHeaderTable hs0

222 tbl <- toHeaderTable hs0

221 let !rspn = RspnStreaming s0 tbl tbq

223 let !rspn = RspnStreaming s0 tbl tbq

222− !out = Output strm rspn ii tell rspnOrWait

224+ !out = Output strm rspn ii tell h2data rspnOrWait

223 enqueueOutput outputQ out

225 enqueueOutput outputQ out

224 let push b = do

226 let push b = do

225 atomically $ writeTBQueue tbq (SBuilder b)

227 atomically $ writeTBQueue tbq (SBuilder b)