72b6292 · typeable/wai

git.iko.soy/typeable/wai

defining APIs for HTTP/2 trailers.

commit72b62923ec00a5fc4786163f21b63b1d26652923 authorKazu Yamamoto <kazu@iij.ad.jp> dateThu 14 Jul 2016, 13:50 (10 years ago) parent473457b

5 files changed+72−32

compare with master

unifiedsplit

warp/Network/Wai/Handler/Warp.hs+3−1 warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+16−1 warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+39−21 warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+7−4 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+7−5

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

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

104104 -- ** HTTP2 data

105105 , HTTP2Data

106106 , http2dataPushPromise

107+ , http2dataTrailers

107108 , defaultHTTP2Data

108109 , getHTTP2Data

109110 , setHTTP2Data

111+ , modifyHTTP2Data

110112 -- ** Push promise

111113 , PushPromise

112114 , promisedPath

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

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

130132import Network.Wai.Handler.Warp.Run

131133import 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)

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

134136import Network.Wai.Handler.Warp.Timeout

135137import 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 (

66 , MkReq

77 , getHTTP2Data

88 , setHTTP2Data

9+ , modifyHTTP2Data

910 ) where

1011

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

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

8384 $ Vault.insert getFileInfoKey (getFileInfo ii)

8485 $ Vault.insert getHTTP2DataKey (readIORef ref)

8586 $ Vault.insert setHTTP2DataKey (writeIORef ref)

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

8688 Vault.empty

8789

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

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

103105{-# NOINLINE setHTTP2Data #-}

104106

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

106−-- 'Middleware' should use this.

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

107109--

108110-- Since: 3.2.7

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

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

111113 Nothing -> return ()

112114 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)

1818import Data.Word (Word8, Word32)

1919import Foreign.Ptr (Ptr, plusPtr)

2020import Foreign.Storable (poke)

21−import Network.HPACK (setLimitForEncoding)

21+import Network.HPACK (setLimitForEncoding, toHeaderTable)

2222import Network.HTTP2

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

2424import Network.Wai

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

122122 Nothing -> return ()

123123 Just siz -> setLimitForEncoding siz encodeDynamicTable

124124

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

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

126126 -- Data frame payload

127127 let !buf = connWriteBuffer `plusPtr` off0

128128 !siz = connBufferSize - off0

129129 Next datPayloadLen mnext <- curr buf siz lim

130− off <- fillDataHeader strm off0 datPayloadLen mnext tell

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

131131 maybeEnqueueNext out mnext

132132 return off

133133

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

135135 -- Header frame and Continuation frame

136136 let !sid = streamNumber strm

137137 !endOfStream = case rspn of

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

149149 let payloadOff = off + frameHeaderLength

150150 Next datPayloadLen mnext <-

151151 fillFileBodyGetNext conn ii payloadOff lim path mpart

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

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

153153 maybeEnqueueNext out mnext

154154 return off'

155155 RspnBuilder _ _ builder -> do

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

157157 let payloadOff = off + frameHeaderLength

158158 Next datPayloadLen mnext <-

159159 fillBuilderBodyGetNext conn ii payloadOff lim builder

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

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

161161 maybeEnqueueNext out mnext

162162 return off'

163163 RspnStreaming _ _ tbq -> do

164164 let payloadOff = off + frameHeaderLength

165165 Next datPayloadLen mnext <-

166166 fillStreamBodyGetNext conn payloadOff lim tbq strm

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

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

168168 maybeEnqueueNext out mnext

169169 return off'

170170

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

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

172172 -- Creating a push promise header

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

174174 let !sid = streamNumber strm

175175 len <- pushPromise pid sid ths off0

176176 off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len

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

177+ output out{ outputType = ORspn } off lim

178178

179179 output _ _ _ = undefined -- never reach

180180

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

183183 if isClosed state then

184184 return off

185185 else case out of

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

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

187187 -- 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+ }

189192 forkAndEnqueueWhenReady wait outputQ out' mgr

190193 return off

191194 _ -> case mtbq of

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

268271 flushN off

269272 return 0

270273

271− fillDataHeader strm off datPayloadLen mnext tell = do

274+ fillDataHeader strm@Stream{streamWindow,streamNumber}

275+ off datPayloadLen mnext tell getH2D = do

272276 -- 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)

274281 !buf = connWriteBuffer `plusPtr` off

275282 !off' = off + frameHeaderLength + datPayloadLen

276− !done = isNothing mnext

277− flag | done = setEndStream defaultFlags

278− | otherwise = defaultFlags

279− fillFrameHeader FrameData datPayloadLen sid flag buf

280− when done $ do

283+ !noMoreBody = isNothing mnext

284+ flag | noMoreBody && noTrailers = setEndStream defaultFlags

285+ | otherwise = defaultFlags

286+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf

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

281299 void $ tell

282300 closed ctx strm Finished

283− atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

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

285− return off'

301+ return off1

302+ handleEndOfBody False off0 _ _ = return off0

303+

286304

287305 pushPromise pid sid ths off = do

288306 let !offsid = off + frameHeaderLength

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

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

7373 , outputRspn :: !Rspn

7474 , outputII :: !InternalInfo

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

76+ , outputH2Data :: IO (Maybe HTTP2Data)

7677 , outputType :: !OutputType

7778 }

7879

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

8283 | ONext !DynaNext

8384

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

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

86−outputMaybeTBQueue _ = Nothing

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

87+outputMaybeTBQueue _ = Nothing

8788

8889data Control = CFinish

8990 | CGoaway !ByteString

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

281282-- | HTTP/2 specific data.

282283--

283284-- Since: 3.2.7

284−newtype HTTP2Data = HTTP2Data {

285+data HTTP2Data = HTTP2Data {

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

286287 --

287288 -- Since: 3.2.7

288289 http2dataPushPromise :: [PushPromise]

290+ -- Since: 3.2.8

291+ , http2dataTrailers :: H.ResponseHeaders

289292 } deriving (Eq,Show)

290293

291294-- | Default HTTP/2 specific data.

292295--

293296-- Since: 3.2.7

294297defaultHTTP2Data :: HTTP2Data

295−defaultHTTP2Data = HTTP2Data []

298+defaultHTTP2Data = HTTP2Data [] []

296299

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

298301--

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

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

8181 waiter lim tvar = atomically $ do

8282 n <- readTVar tvar

8383 check (n >= lim)

84+ !h2data = getHTTP2Data req

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

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

8687 let !file = promisedFile pp

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

111112 addContentHeadersForFilePart ths0 part

112113 pushLogger req path size

113114 let !ot = OPush promisedRequest pid

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

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

115116 enqueueOutput outputQ out

116117 push tvar pps (n + 1)

117118

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

145146 !logger = S.settingsLogger settings

146147 !th = threadHandle ii

147148 sid = streamNumber strm

149+ !h2data = getHTTP2Data req

148150

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

150152 -- 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

158160 logger req s Nothing

159161 setThreadContinue tconf True

160162 let !rspn = RspnNobody s tbl

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

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

162164 enqueueOutput outputQ out

163165 return ResponseReceived

164166

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

167169 setThreadContinue tconf True

168170 tbl <- toHeaderTable hs0

169171 let !rspn = RspnBuilder s tbl bdy

170− !out = Output strm rspn ii tell rspnOrWait

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

171173 enqueueOutput outputQ out

172174 return ResponseReceived

173175

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

193195 logger req s (filePartByteCount <$> mpart)

194196 setThreadContinue tconf True

195197 let !rspn = RspnFile s tbl path mpart

196− !out = Output strm rspn ii tell rspnOrWait

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

197199 enqueueOutput outputQ out

198200 return ResponseReceived

199201

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

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

220222 tbl <- toHeaderTable hs0

221223 let !rspn = RspnStreaming s0 tbl tbq

222− !out = Output strm rspn ii tell rspnOrWait

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

223225 enqueueOutput outputQ out

224226 let push b = do

225227 atomically $ writeTBQueue tbq (SBuilder b)