39a7968 · typeable/wai

git.iko.soy/typeable/wai

Merge branch 'trailers' (#566)

commit39a79687f2b7c288d5f0bafef864751110ae2c7c authorKazu Yamamoto <kazu@iij.ad.jp> dateTue 19 Jul 2016, 14:11 (10 years ago) parente78cefa 72b6292

5 files changed+99−64

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+47−30 warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+19−21 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+14−11

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+47−30

@@ -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 (ONext strm curr mtbq tell) 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

131− maybeEnqueueNext strm mtbq mnext tell

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

131+ maybeEnqueueNext out mnext

132132 return off

133133

134− output (ORspn strm rspn ii tell) 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,32 +149,32 @@ 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

153− maybeEnqueueNext strm Nothing mnext tell

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

153+ maybeEnqueueNext out mnext

154154 return off'

155155 RspnBuilder _ _ builder -> do

156156 -- Data frame payload

157157 let payloadOff = off + frameHeaderLength

158158 Next datPayloadLen mnext <-

159159 fillBuilderBodyGetNext conn ii payloadOff lim builder

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

161− maybeEnqueueNext strm Nothing mnext tell

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

161+ 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

168− maybeEnqueueNext strm (Just tbq) mnext tell

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

168+ maybeEnqueueNext out mnext

169169 return off'

170170

171− output (OPush strm ths rspn ii tell 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 (ORspn strm rspn ii tell) 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− OWait strm' rsp ii wait -> do

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

187187 -- Checking if all push are done.

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

188+ let out' = out {

189+ outputHook = return ()

190+ , outputType = ORspn

191+ }

189192 forkAndEnqueueWhenReady wait outputQ out' mgr

190193 return off

191194 _ -> case mtbq of

@@ -252,12 +255,11 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

252255

253256 {-# INLINE maybeEnqueueNext #-}

254257 -- Re-enqueue the stream in the output queue.

255− maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence)

256− -> Maybe DynaNext -> IO () -> IO ()

257− maybeEnqueueNext _ _ Nothing _ = return ()

258− maybeEnqueueNext strm mtbq (Just next) tell = enqueueOutput outputQ out

258+ maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()

259+ maybeEnqueueNext _ Nothing = return ()

260+ maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'

259261 where

260− !out = ONext strm next mtbq tell

262+ !out' = out { outputType = ONext next }

261263

262264 {-# INLINE sendHeadersIfNecessary #-}

263265 -- Send headers if there is not room for a 1-byte data frame, and return

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

269271 flushN off

270272 return 0

271273

272− fillDataHeader strm off datPayloadLen mnext tell = do

274+ fillDataHeader strm@Stream{streamWindow,streamNumber}

275+ off datPayloadLen mnext tell getH2D = do

273276 -- Data frame header

274− let !sid = streamNumber strm

277+ mh2d <- getH2D

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

279+ Nothing -> ([], True)

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

275281 !buf = connWriteBuffer `plusPtr` off

276282 !off' = off + frameHeaderLength + datPayloadLen

277− !done = isNothing mnext

278− flag | done = setEndStream defaultFlags

279− | otherwise = defaultFlags

280− fillFrameHeader FrameData datPayloadLen sid flag buf

281− 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

282299 void $ tell

283300 closed ctx strm Finished

284− atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

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

286− return off'

301+ return off1

302+ handleEndOfBody False off0 _ _ = return off0

303+

287304

288305 pushPromise pid sid ths off = do

289306 let !offsid = off + frameHeaderLength

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

@@ -68,27 +68,23 @@ rspnHeaders (RspnStreaming _ t _) = t

6868rspnHeaders (RspnBuilder _ t _) = t

6969rspnHeaders (RspnFile _ t _ _ ) = t

7070

71−data Output = ORspn !Stream !Rspn !InternalInfo (IO ()) -- done

72− | OWait !Stream !Rspn !InternalInfo (IO ()) -- done

73− | OPush !Stream -- stream for this push from this server

74− TokenHeaderList

75− !Rspn {- RspnFile only-}

76− !InternalInfo (IO ()) -- wait for done

77− !StreamId -- associated stream id from client

78− | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence)) (IO ()) -- done

79−

80−outputStream :: Output -> Stream

81−outputStream (ORspn strm _ _ _) = strm

82−outputStream (OPush strm _ _ _ _ _) = strm

83−outputStream (OWait strm _ _ _) = strm

84−outputStream (ONext strm _ _ _) = strm

71+data Output = Output {

72+ outputStream :: !Stream

73+ , outputRspn :: !Rspn

74+ , outputII :: !InternalInfo

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

76+ , outputH2Data :: IO (Maybe HTTP2Data)

77+ , outputType :: !OutputType

78+ }

79+

80+data OutputType = ORspn

81+ | OWait

82+ | OPush !TokenHeaderList !StreamId -- associated stream id from client

83+ | ONext !DynaNext

8584

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

87−outputMaybeTBQueue (ORspn _ (RspnStreaming _ _ tbq) _ _) = Just tbq

88−outputMaybeTBQueue (ORspn _ _ _ _) = Nothing

89−outputMaybeTBQueue (OPush _ _ _ _ _ _) = Nothing

90−outputMaybeTBQueue (OWait _ _ _ _) = Nothing

91−outputMaybeTBQueue (ONext _ _ mtbq _) = mtbq

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

87+outputMaybeTBQueue _ = Nothing

9288

9389data Control = CFinish

9490 | CGoaway !ByteString

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

286282-- | HTTP/2 specific data.

287283--

288284-- Since: 3.2.7

289−newtype HTTP2Data = HTTP2Data {

285+data HTTP2Data = HTTP2Data {

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

291287 --

292288 -- Since: 3.2.7

293289 http2dataPushPromise :: [PushPromise]

290+ -- Since: 3.2.8

291+ , http2dataTrailers :: H.ResponseHeaders

294292 } deriving (Eq,Show)

295293

296294-- | Default HTTP/2 specific data.

297295--

298296-- Since: 3.2.7

299297defaultHTTP2Data :: HTTP2Data

300−defaultHTTP2Data = HTTP2Data []

298+defaultHTTP2Data = HTTP2Data [] []

301299

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

303301--

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+14−11

@@ -57,7 +57,7 @@ type Responder = InternalInfo

5757pushStream :: Context -> S.Settings

5858 -> StreamId -> ValueTable -> Request -> InternalInfo

5959 -> Maybe HTTP2Data

60− -> IO (Stream -> Rspn -> InternalInfo -> IO () -> Output, IO ())

60+ -> IO (OutputType, IO ())

6161pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())

6262pushStream ctx@Context{http2settings,outputQ,streamTable}

6363 settings pid reqvt req ii (Just h2d)

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

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

110111 !ths = (tokenLastModified,date) :

111112 addContentHeadersForFilePart ths0 part

112113 pushLogger req path size

113− let out = OPush strm promisedRequest rsp ii (increment tvar) pid

114+ let !ot = OPush promisedRequest pid

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

114116 enqueueOutput outputQ out

115117 push tvar pps (n + 1)

116118

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

144146 !logger = S.settingsLogger settings

145147 !th = threadHandle ii

146148 sid = streamNumber strm

149+ !h2data = getHTTP2Data req

147150

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

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

@@ -156,8 +159,8 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

156159 responseNoBody' s tbl = do

157160 logger req s Nothing

158161 setThreadContinue tconf True

159− let rspn = RspnNobody s tbl

160− out = ORspn strm rspn ii (return ())

162+ let !rspn = RspnNobody s tbl

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

161164 enqueueOutput outputQ out

162165 return ResponseReceived

163166

@@ -165,8 +168,8 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

165168 logger req s Nothing

166169 setThreadContinue tconf True

167170 tbl <- toHeaderTable hs0

168− let rspn = RspnBuilder s tbl bdy

169− out = rspnOrWait strm rspn ii tell

171+ let !rspn = RspnBuilder s tbl bdy

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

170173 enqueueOutput outputQ out

171174 return ResponseReceived

172175

@@ -191,8 +194,8 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

191194 | otherwise = do

192195 logger req s (filePartByteCount <$> mpart)

193196 setThreadContinue tconf True

194− let rspn = RspnFile s tbl path mpart

195− out = rspnOrWait strm rspn ii tell

197+ let !rspn = RspnFile s tbl path mpart

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

196199 enqueueOutput outputQ out

197200 return ResponseReceived

198201

@@ -217,8 +220,8 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rs

217220 -- So, let's serialize 'Builder' with a designated queue.

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

219222 tbl <- toHeaderTable hs0

220− let rspn = RspnStreaming s0 tbl tbq

221− out = rspnOrWait strm rspn ii tell

223+ let !rspn = RspnStreaming s0 tbl tbq

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

222225 enqueueOutput outputQ out

223226 let push b = do

224227 atomically $ writeTBQueue tbq (SBuilder b)

@@ -265,7 +268,7 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do

265268 Nothing -> return ()

266269 Just (Input strm req _reqvt _ii) -> do

267270 closed ctx strm Killed

268− let frame = resetFrame InternalError (streamNumber strm)

271+ let !frame = resetFrame InternalError (streamNumber strm)

269272 enqueueControl controlQ $ CFrame frame

270273 case me of

271274 Nothing -> return ()