9faea50 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Getting back to Warp 3.1.3's HTTP/2 code.

9faea50Kazu Yamamoto11 years ago

wai/Network/Wai/HTTP2.hsdeleted−272

compare with master

unifiedsplit

@@ -1,272 +0,0 @@

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

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DeriveDataTypeable #-}

4−

5−-- | An HTTP\/2-aware variant of the 'Network.Wai.Application' type. Compared

6−-- to the original, this exposes the new functionality of server push and

7−-- trailers, allows stream fragments to be sent in the form of file ranges, and

8−-- allows the stream body to produce a value to be used in constructing the

9−-- trailers. Existing @Applications@ can be faithfully upgraded to HTTP\/2

10−-- with 'promoteApplication' or served transparently over both protocols with

11−-- the normal Warp 'Network.Wai.Handler.Warp.run' family of functions.

12−--

13−-- An 'HTTP2Application' takes a 'Request' and a 'PushFunc' and produces a

14−-- 'Responder' that will push any associated resources and send the response

15−-- body. The response is always a stream of 'Builder's and file chunks.

16−-- Equivalents of the 'Network.Wai.responseBuilder' family of functions are

17−-- provided for creating 'Responder's conveniently.

18−--

19−-- Pushed streams are handled by an IO action that triggers a server push. It

20−-- returns @True@ if the @PUSH_PROMISE@ frame was sent, @False@ if not. Note

21−-- this means it will still return @True@ if the client reset or ignored the

22−-- stream. This gives handlers the freedom to implement their own heuristics

23−-- for whether to actually push a resource, while also allowing middleware and

24−-- frameworks to trigger server pushes automatically.

25−

26−module Network.Wai.HTTP2

27− (

28− -- * Applications

29− HTTP2Application

30− -- * Responder

31− , Responder(..)

32− , RespondFunc

33− , Body

34− , Chunk(..)

35− , Trailers

36− -- * Server push

37− , PushFunc

38− , PushPromise(..)

39− , promiseHeaders

40− -- * Conveniences

41− , promoteApplication

42− -- ** Responders

43− , respond

44− , respondCont

45− , respondIO

46− , respondFile

47− , respondFilePart

48− , respondNotFound

49− , respondWith

50− -- ** Stream Bodies

51− , streamFilePart

52− , streamBuilder

53− , streamSimple

54− ) where

55−

56−import Blaze.ByteString.Builder (Builder)

57−import Blaze.ByteString.Builder.ByteString (fromByteString)

58−import Control.Exception (Exception, throwIO)

59−import Control.Monad.Trans.Cont (ContT(..))

60−import Data.ByteString (ByteString)

61−#if __GLASGOW_HASKELL__ < 709

62−import Data.Functor ((<$>))

63−#endif

64−import Data.IORef (newIORef, readIORef, writeIORef)

65−#if __GLASGOW_HASKELL__ < 709

66−import Data.Monoid (mempty)

67−#endif

68−import Data.Typeable (Typeable)

69−import qualified Network.HTTP.Types as H

70−

71−import Network.Wai (Application)

72−import Network.Wai.Internal

73− ( FilePart(..)

74− , Request(requestHeaders)

75− , Response(..)

76− , ResponseReceived(..)

77− , StreamingBody

78− , adjustForFilePart

79− , chooseFilePart

80− , tryGetFileSize

81− )

82−

83−-- | Headers sent after the end of a data stream, as defined by section 4.1.2 of

84−-- the HTTP\/1.1 spec (RFC 7230), and section 8.1 of the HTTP\/2 spec.

85−type Trailers = [H.Header]

86−

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

88−data PushPromise = PushPromise

89− { promisedMethod :: H.Method

90− , promisedPath :: ByteString

91− , promisedAuthority :: ByteString

92− , promisedScheme :: ByteString

93− , promisedHeader :: H.RequestHeaders

94− }

95−

96−-- | The HTTP\/2-aware equivalent of 'Network.Wai.Application'.

97−type HTTP2Application = Request -> PushFunc -> Responder

98−

99−-- | Part of a streaming response -- either a 'Builder' or a range of a file.

100−data Chunk = FileChunk FilePath FilePart | BuilderChunk Builder

101−

102−-- | The streaming body of a response. Equivalent to

103−-- 'Network.Wai.StreamingBody' except that it can also write file ranges and

104−-- return the stream's trailers.

105−type Body = (Chunk -> IO ()) -> IO () -> IO Trailers

106−

107−-- | Given to 'Responders'; provide a status, headers, and a stream body, and

108−-- we'll give you a token proving you called the 'RespondFunc'.

109−type RespondFunc s = H.Status -> H.ResponseHeaders -> Body -> IO s

110−

111−-- | The result of an 'HTTP2Application'; or, alternately, an application

112−-- that's independent of the request. This is a continuation-passing style

113−-- function that first provides a response by calling the given respond

114−-- function, then returns the request's 'Trailers'.

115−--

116−-- The respond function is similar to the one in 'Network.Wai.Application', but

117−-- it only takes a streaming body, the status and headers are curried, and it

118−-- also produces trailers for the stream.

119−newtype Responder = Responder

120− { runResponder :: forall s. RespondFunc s -> IO s }

121−

122−-- | A function given to an 'HTTP2Application' to initiate a server-pushed

123−-- stream. Its argument is the same as the result of an 'HTTP2Application', so

124−-- you can either implement the response inline, or call your own application

125−-- to create the response.

126−--

127−-- The result is 'True' if the @PUSH_PROMISE@ frame will be sent, or 'False' if

128−-- it will not. This can happen if server push is disabled, the concurrency

129−-- limit of server-initiated streams is reached, or the associated stream has

130−-- already been closed.

131−--

132−-- This function shall ensure that stream data provided after it returns will

133−-- be sent after the @PUSH_PROMISE@ frame, so that servers can implement the

134−-- requirement that any pushed stream for a resource be initiated before

135−-- sending DATA frames that reference it.

136−type PushFunc = PushPromise -> Responder -> IO Bool

137−

138−-- | Create the 'H.RequestHeaders' corresponding to the given 'PushPromise'.

139−--

140−-- This is primarily useful for WAI handlers like Warp, and application

141−-- implementers are unlikely to use it directly.

142−promiseHeaders :: PushPromise -> H.RequestHeaders

143−promiseHeaders p =

144− [ (":method", promisedMethod p)

145− , (":path", promisedPath p)

146− , (":authority", promisedAuthority p)

147− , (":scheme", promisedScheme p)

148− ] ++ promisedHeader p

149−

150−-- | Create a response body consisting of a single range of a file. Does not

151−-- set Content-Length or Content-Range headers. For that, use

152−-- 'respondFilePart' or 'respondFile'.

153−streamFilePart :: FilePath -> FilePart -> Body

154−streamFilePart path part write _ = write (FileChunk path part) >> return []

155−

156−-- | Respond with a single range of a file, adding the Accept-Ranges,

157−-- Content-Length and Content-Range headers and changing the status to 206 as

158−-- appropriate.

159−--

160−-- If you want the range to be inferred automatically from the Range header,

161−-- use 'respondFile' instead. On the other hand, if you want to avoid the

162−-- automatic header and status adjustments, use 'respond' and 'streamFilePart'

163−-- directly.

164−respondFilePart :: H.Status -> H.ResponseHeaders -> FilePath -> FilePart -> Responder

165−respondFilePart s h path part = Responder $ \k -> do

166− let (s', h') = adjustForFilePart s h part

167− k s' h' $ streamFilePart path part

168−

169−-- | Serve the requested range of the specified file (based on the Range

170−-- header), using the given 'H.Status' and 'H.ResponseHeaders' as a base. If

171−-- the file is not accessible, the status will be replaced with 404 and a

172−-- default not-found message will be served. If a partial file is requested,

173−-- the status will be replaced with 206 and the Content-Range header will be

174−-- added. The Content-Length header will always be added.

175−respondFile :: H.Status -> H.ResponseHeaders -> FilePath -> H.RequestHeaders -> Responder

176−respondFile s h path reqHdrs = Responder $ \k -> do

177− fileSize <- tryGetFileSize path

178− case fileSize of

179− Left _ -> runResponder (respondNotFound h) k

180− Right size -> runResponder (respondFileExists s h path size reqHdrs) k

181−

182−-- As 'respondFile', but with prior knowledge of the file's existence and size.

183−respondFileExists :: H.Status -> H.ResponseHeaders -> FilePath -> Integer -> H.RequestHeaders -> Responder

184−respondFileExists s h path size reqHdrs =

185− respondFilePart s h path $ chooseFilePart size $ lookup H.hRange reqHdrs

186−

187−-- | Respond with a minimal 404 page with the given headers.

188−respondNotFound :: H.ResponseHeaders -> Responder

189−respondNotFound h = Responder $ \k -> k H.notFound404 h' $

190− streamBuilder $ fromByteString "File not found."

191− where

192− contentType = (H.hContentType, "text/plain; charset=utf-8")

193− h' = contentType:filter ((/=H.hContentType) . fst) h

194−

195−-- | Construct a 'Responder' that will just call the 'RespondFunc' with the

196−-- given arguments.

197−respond :: H.Status -> H.ResponseHeaders -> Body -> Responder

198−respond s h b = Responder $ \k -> k s h b

199−

200−-- | Fold the given bracketing action into a 'Responder'. Note the first

201−-- argument is isomorphic to @Codensity IO a@ or @forall s. ContT s IO a@, and

202−-- is the type of a partially-applied 'Control.Exception.bracket' or

203−-- @with@-style function.

204−--

205−-- > respondWith (bracket acquire release) $

206−-- > \x -> respondNotFound [("x", show x)]

207−--

208−-- is equivalent to

209−--

210−-- > Responder $ \k -> bracket acquire release $

211−-- > \x -> runResponder (respondNotFound [("x", show x)] k

212−--

213−-- This is morally equivalent to ('>>=') on 'Codensity' 'IO'.

214−respondWith :: (forall s. (a -> IO s) -> IO s) -> (a -> Responder) -> Responder

215−respondWith with f = respondCont $ f <$> ContT with

216−

217−-- | Fold the 'ContT' into the contained 'Responder'.

218−respondCont :: (forall r. ContT r IO Responder) -> Responder

219−respondCont cont = Responder $ \k -> runContT cont $ \r -> runResponder r k

220−

221−-- | Fold the 'IO' into the contained 'Responder'.

222−respondIO :: IO Responder -> Responder

223−respondIO io = Responder $ \k -> io >>= \r -> runResponder r k

224−

225−-- | Create a response body consisting of a single builder.

226−streamBuilder :: Builder -> Body

227−streamBuilder builder write _ = write (BuilderChunk builder) >> return []

228−

229−-- | Create a response body of a stream of 'Builder's.

230−streamSimple :: StreamingBody -> Body

231−streamSimple body write flush = body (write . BuilderChunk) flush >> return []

232−

233−-- | Use a normal WAI 'Response' to send the response. Useful if you're

234−-- sharing code between HTTP\/2 applications and HTTP\/1 applications.

235−--

236−-- The 'Request' is used to determine the right file range to serve for

237−-- 'ResponseFile'.

238−promoteResponse :: Request -> Response -> Responder

239−promoteResponse req response = case response of

240− (ResponseBuilder s h b) ->

241− Responder $ \k -> k s h (streamBuilder b)

242− (ResponseStream s h body) ->

243− Responder $ \k -> k s h (streamSimple body)

244− (ResponseRaw _ fallback) -> promoteResponse req fallback

245− (ResponseFile s h path mpart) -> maybe

246− (respondFile s h path $ requestHeaders req)

247− (respondFilePart s h path)

248− mpart

249−

250−-- | An 'Network.Wai.Application' we tried to promote neither called its

251−-- respond action nor raised; this is only possible if it imported the

252−-- 'ResponseReceived' constructor and used it to lie about having called the

253−-- action.

254−data RespondNeverCalled = RespondNeverCalled deriving (Show, Typeable)

255−

256−instance Exception RespondNeverCalled

257−

258−-- | Promote a normal WAI 'Application' to an 'HTTP2Application' by ignoring

259−-- the HTTP/2-specific features.

260−promoteApplication :: Application -> HTTP2Application

261−promoteApplication app req _ = Responder $ \k -> do

262− -- In HTTP2Applications, the Responder is required to ferry a value of

263− -- arbitrary type from the RespondFunc back to the caller of the

264− -- application, but in Application the type is fixed to ResponseReceived.

265− -- To add this extra power to an Application, we have to squirrel it away

266− -- in an IORef as a hack.

267− ref <- newIORef Nothing

268− let k' r = do

269− writeIORef ref . Just =<< runResponder (promoteResponse req r) k

270− return ResponseReceived

271− ResponseReceived <- app req k'

272− readIORef ref >>= maybe (throwIO RespondNeverCalled) return

wai/Network/Wai/Internal.hs−97

@@ -1,7 +1,6 @@

1{-# OPTIONS_HADDOCK not-home #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE CPP #-}

4−{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE RecordWildCards #-}

7-- | Internal constructors and helper functions. Note that no guarantees are

6-- | Internal constructors and helper functions. Note that no guarantees are

@@ -9,25 +8,17 @@

9module Network.Wai.Internal where

8module Network.Wai.Internal where

11import Blaze.ByteString.Builder (Builder)

10import Blaze.ByteString.Builder (Builder)

12−import Control.Exception (IOException, try)

13import qualified Data.ByteString as B hiding (pack)

11import qualified Data.ByteString as B hiding (pack)

14−import qualified Data.ByteString.Builder as B

15−import qualified Data.ByteString.Char8 as B (pack, readInteger)

16−import qualified Data.ByteString.Lazy as L

17#if __GLASGOW_HASKELL__ < 709

12#if __GLASGOW_HASKELL__ < 709

18import Data.Functor ((<$>))

13import Data.Functor ((<$>))

19#endif

14#endif

20−import Data.Maybe (listToMaybe)

21import Data.Text (Text)

15import Data.Text (Text)

22import Data.Typeable (Typeable)

16import Data.Typeable (Typeable)

23import Data.Vault.Lazy (Vault)

17import Data.Vault.Lazy (Vault)

24import Data.Word (Word64)

18import Data.Word (Word64)

25import qualified Network.HTTP.Types as H

19import qualified Network.HTTP.Types as H

26−import qualified Network.HTTP.Types.Header as HH

27import Network.Socket (SockAddr)

20import Network.Socket (SockAddr)

28−import Numeric (showInt)

29import Data.List (intercalate)

21import Data.List (intercalate)

30−import qualified System.PosixCompat.Files as P

32-- | Information on the request sent by the client. This abstracts away the

23-- | Information on the request sent by the client. This abstracts away the

33-- details of the underlying implementation.

24-- details of the underlying implementation.

@@ -157,91 +148,3 @@ data FilePart = FilePart

157-- Since 3.0.0

148-- Since 3.0.0

158data ResponseReceived = ResponseReceived

149data ResponseReceived = ResponseReceived

159 deriving Typeable

150 deriving Typeable

160−

161−-- | Look up the size of a file in 'Right' or the 'IOException' in 'Left'.

162−tryGetFileSize :: FilePath -> IO (Either IOException Integer)

163−tryGetFileSize path =

164− fmap (fromIntegral . P.fileSize) <$> try (P.getFileStatus path)

165−

166−-- | \"Content-Range\".

167−hContentRange :: H.HeaderName

168−hContentRange = "Content-Range"

169−

170−-- | \"Accept-Ranges\".

171−hAcceptRanges :: H.HeaderName

172−hAcceptRanges = "Accept-Ranges"

173−

174−-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'

175−-- for the range specified.

176−contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

177−contentRangeHeader beg end total = (hContentRange, range)

178− where

179− range = B.pack

180− -- building with ShowS

181− $ 'b' : 'y': 't' : 'e' : 's' : ' '

182− : (if beg > end then ('*':) else

183− showInt beg

184− . ('-' :)

185− . showInt end)

186− ( '/'

187− : showInt total "")

188−

189−-- | Given the full size of a file and optionally a Range header value,

190−-- determine the range to serve by parsing the range header and obeying it, or

191−-- serving the whole file if it's absent or malformed.

192−chooseFilePart :: Integer -> Maybe B.ByteString -> FilePart

193−chooseFilePart size Nothing = FilePart 0 size size

194−chooseFilePart size (Just range) = case parseByteRanges range >>= listToMaybe of

195− -- Range is broken

196− Nothing -> FilePart 0 size size

197− Just hrange -> checkRange hrange

198− where

199− checkRange (H.ByteRangeFrom beg) = fromRange beg (size - 1)

200− checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (size - 1) end)

201− checkRange (H.ByteRangeSuffix count) = fromRange (max 0 (size - count)) (size - 1)

202−

203− fromRange beg end = FilePart beg (end - beg + 1) size

204−

205−-- | Adjust the given 'H.Status' and 'H.ResponseHeaders' based on the given

206−-- 'FilePart'. This means replacing the status with 206 if the response is

207−-- partial, and adding the Content-Length and Accept-Ranges (always) and

208−-- Content-Range (if appropriate) headers.

209−adjustForFilePart :: H.Status -> H.ResponseHeaders -> FilePart -> (H.Status, H.ResponseHeaders)

210−adjustForFilePart s h part = (s', h'')

211− where

212− off = filePartOffset part

213− len = filePartByteCount part

214− size = filePartFileSize part

215−

216− contentRange = contentRangeHeader off (off + len - 1) size

217− lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len

218− s' = if filePartByteCount part /= size then H.partialContent206 else s

219− h' = (H.hContentLength, lengthBS):(hAcceptRanges, "bytes"):h

220− h'' = (if len == size then id else (contentRange:)) h'

221−

222−-- | Parse the value of a Range header into a 'HH.ByteRanges'.

223−parseByteRanges :: B.ByteString -> Maybe HH.ByteRanges

224−parseByteRanges bs1 = do

225− bs2 <- stripPrefix "bytes=" bs1

226− (r, bs3) <- range bs2

227− ranges (r:) bs3

228− where

229− range bs2 = do

230− (i, bs3) <- B.readInteger bs2

231− if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")

232− then Just (HH.ByteRangeSuffix (negate i), bs3)

233− else do

234− bs4 <- stripPrefix "-" bs3

235− case B.readInteger bs4 of

236− Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5)

237− _ -> Just (HH.ByteRangeFrom i, bs4)

238− ranges front bs3

239− | B.null bs3 = Just (front [])

240− | otherwise = do

241− bs4 <- stripPrefix "," bs3

242− (r, bs5) <- range bs4

243− ranges (front . (r:)) bs5

244−

245− stripPrefix x y

246− | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)

247− | otherwise = Nothing

wai/wai.cabal−2

@@ -27,10 +27,8 @@ Library

27 , http-types >= 0.7

28 , text >= 0.7

29 , transformers >= 0.0

30− , unix-compat >= 0.2

31 , vault >= 0.3 && < 0.4

30 , vault >= 0.3 && < 0.4

32 Exposed-modules: Network.Wai

31 Exposed-modules: Network.Wai

33− Network.Wai.HTTP2

34 Network.Wai.Internal

32 Network.Wai.Internal

35 ghc-options: -Wall

33 ghc-options: -Wall

warp-tls/Network/Wai/Handler/WarpTLS.hs+7−29

@@ -35,8 +35,6 @@ module Network.Wai.Handler.WarpTLS (

35 -- * Runner

36 , runTLS

37 , runTLSSocket

38− , runHTTP2TLS

39− , runHTTP2TLSSocket

40 -- * Exception

38 -- * Exception

41 , WarpTLSException (..)

39 , WarpTLSException (..)

42 ) where

40 ) where

@@ -60,7 +58,6 @@ import Network.Socket.ByteString (sendAll)

60import qualified Network.TLS as TLS

58import qualified Network.TLS as TLS

61import qualified Network.TLS.Extra as TLSExtra

59import qualified Network.TLS.Extra as TLSExtra

62import Network.Wai (Application)

60import Network.Wai (Application)

63−import Network.Wai.HTTP2 (HTTP2Application)

64import Network.Wai.Handler.Warp

61import Network.Wai.Handler.Warp

65import Network.Wai.Handler.Warp.Internal

62import Network.Wai.Handler.Warp.Internal

66import System.IO.Error (isEOFError)

63import System.IO.Error (isEOFError)

@@ -221,39 +218,20 @@ tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings

221

218

222----------------------------------------------------------------

219----------------------------------------------------------------

223

220

224−-- Composition over two arguments at once; used for runHTTP2\*.

225−(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

226−f .: g = curry $ f . uncurry g

227−

228-- | Running 'Application' with 'TLSSettings' and 'Settings'.

221-- | Running 'Application' with 'TLSSettings' and 'Settings'.

229runTLS :: TLSSettings -> Settings -> Application -> IO ()

222runTLS :: TLSSettings -> Settings -> Application -> IO ()

230−runTLS tset set = runServeTLS tset set . serveDefault

231−

232−-- | Run an HTTP\/2-aware server with 'TLSSettings' and 'Settings'.

233−runHTTP2TLS :: TLSSettings -> Settings -> HTTP2Application -> Application -> IO ()

234−runHTTP2TLS tset set = runServeTLS tset set .: serveHTTP2

235−

236−runServeTLS :: TLSSettings -> Settings -> ServeConnection -> IO ()

237−runServeTLS tset set serve = withSocketsDo $

223+runTLS tset set app = withSocketsDo $

238 bracket

224 bracket

239 (bindPortTCP (getPort set) (getHost set))

225 (bindPortTCP (getPort set) (getHost set))

240 sClose

226 sClose

241− (\sock -> runServeTLSSocket tset set sock serve)

227+ (\sock -> runTLSSocket tset set sock app)

242

228

243----------------------------------------------------------------

229----------------------------------------------------------------

244

230

245-- | Running 'Application' with 'TLSSettings' and 'Settings' using

231-- | Running 'Application' with 'TLSSettings' and 'Settings' using

246-- specified 'Socket'.

232-- specified 'Socket'.

247runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()

233runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()

248−runTLSSocket tset set sock = runServeTLSSocket tset set sock . serveDefault

249−

250−-- | Run an HTTP\/2-aware server with 'TLSSettings' and 'Settings' using

251−-- specified 'Socket'.

252−runHTTP2TLSSocket :: TLSSettings -> Settings -> Socket -> HTTP2Application -> Application -> IO ()

253−runHTTP2TLSSocket tset set sock = runServeTLSSocket tset set sock .: serveHTTP2

254−

255−runServeTLSSocket :: TLSSettings -> Settings -> Socket -> ServeConnection -> IO ()

256−runServeTLSSocket tlsset@TLSSettings{..} set sock serve = do

234+runTLSSocket tlsset@TLSSettings{..} set sock app = do

257 credential <- case (certMemory, keyMemory) of

235 credential <- case (certMemory, keyMemory) of

258 (Nothing, Nothing) ->

236 (Nothing, Nothing) ->

259 either error id <$>

237 either error id <$>

@@ -263,11 +241,11 @@ runServeTLSSocket tlsset@TLSSettings{..} set sock serve = do

263 key <- maybe (S.readFile keyFile) return mkey

241 key <- maybe (S.readFile keyFile) return mkey

264 either error return $

242 either error return $

265 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key

243 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key

266− runServeTLSSocket' tlsset set credential sock serve

244+ runTLSSocket' tlsset set credential sock app

267

245

268−runServeTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> ServeConnection -> IO ()

246+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()

269−runServeTLSSocket' tlsset@TLSSettings{..} set credential sock serve =

247+runTLSSocket' tlsset@TLSSettings{..} set credential sock app =

270− runServeSettingsConnectionMakerSecure set get serve

248+ runSettingsConnectionMakerSecure set get app

271 where

249 where

272 get = getter tlsset sock params

250 get = getter tlsset sock params

273 params = TLS.ServerParams {

251 params = TLS.ServerParams {

warp/Network/Wai/Handler/Warp.hs−9

@@ -44,15 +44,6 @@ module Network.Wai.Handler.Warp (

44 , runEnv

45 , runSettings

46 , runSettingsSocket

47− -- * Run an HTTP\/2-aware server

48− -- | Each of these takes an HTTP\/2-aware application as well as a backup

49− -- 'Application' to be used for HTTP\/1.1 and HTTP\/1 connections. These

50− -- are only needed if your application needs access to HTTP\/2-specific

51− -- features such as trailers or pushed streams.

52− , runHTTP2

53− , runHTTP2Env

54− , runHTTP2Settings

55− , runHTTP2SettingsSocket

56 -- * Settings

47 -- * Settings

57 , Settings

48 , Settings

58 , defaultSettings

49 , defaultSettings

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

@@ -7,11 +7,9 @@ import Control.Concurrent (forkIO, killThread)

7import qualified Control.Exception as E

8import Control.Monad (when, unless, replicateM_)

9import Data.ByteString (ByteString)

10−

11import Network.HTTP2

10import Network.HTTP2

12import Network.Socket (SockAddr)

11import Network.Socket (SockAddr)

13−

14−import Network.Wai.HTTP2 (HTTP2Application)

12+import Network.Wai

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

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

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

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

17import Network.Wai.Handler.Warp.HTTP2.Receiver

15import Network.Wai.Handler.Warp.HTTP2.Receiver

@@ -24,7 +22,7 @@ import Network.Wai.Handler.Warp.Types

25----------------------------------------------------------------

23----------------------------------------------------------------

27−http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> HTTP2Application -> IO ()

25+http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()

28http2 conn ii addr transport settings readN app = do

26http2 conn ii addr transport settings readN app = do

29 checkTLS

27 checkTLS

30 ok <- checkPreface

28 ok <- checkPreface

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+13−37

@@ -5,7 +5,6 @@ module Network.Wai.Handler.Warp.HTTP2.HPACK where

6import Control.Arrow (first)

7import qualified Control.Exception as E

8−import qualified Data.ByteString as B

9import Data.ByteString.Builder (Builder)

8import Data.ByteString.Builder (Builder)

10import qualified Data.ByteString.Char8 as B8

9import qualified Data.ByteString.Char8 as B8

11import Data.CaseInsensitive (foldedCase)

10import Data.CaseInsensitive (foldedCase)

@@ -13,39 +12,30 @@ import Data.IORef (readIORef, writeIORef)

13import Network.HPACK

12import Network.HPACK

14import qualified Network.HTTP.Types as H

13import qualified Network.HTTP.Types as H

15import Network.HTTP2

14import Network.HTTP2

15+import Network.Wai

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

17import Network.Wai.Handler.Warp.Header

18import Network.Wai.Handler.Warp.Response

19import qualified Network.Wai.Handler.Warp.Settings as S

20import Network.Wai.Handler.Warp.Types

22−-- $setup

23−-- >>> :set -XOverloadedStrings

24−

25−-- Set-Cookie: contains only one cookie value.

26−-- So, we don't need to split it.

27−hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> H.Status

22+hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response

28− -> H.ResponseHeaders -> IO Builder

23+ -> IO Builder

29−hpackEncodeHeader ctx ii settings s h = do

24+hpackEncodeHeader Context{encodeDynamicTable} ii settings rsp = do

30− hdr1 <- addServerAndDate h

25+ hdr1 <- addServerAndDate hdr0

31 let hdr2 = (":status", status) : map (first foldedCase) hdr1

26 let hdr2 = (":status", status) : map (first foldedCase) hdr1

32− hpackEncodeRawHeaders ctx hdr2

27+ ehdrtbl <- readIORef encodeDynamicTable

28+ (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr2

29+ writeIORef encodeDynamicTable ehdrtbl'

30+ return builder

33 where

31 where

32+ hdr0 = responseHeaders rsp

34− status = B8.pack $ show $ H.statusCode $ s

33+ status = B8.pack $ show $ H.statusCode $ responseStatus rsp

35 dc = dateCacher ii

34 dc = dateCacher ii

36− rspidxhdr = indexResponseHeader h

35+ rspidxhdr = indexResponseHeader hdr0

37 defServer = S.settingsServerName settings

36 defServer = S.settingsServerName settings

38 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

37 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

40−hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder

41−hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase)

42−

43−hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder

44−hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do

45− ehdrtbl <- readIORef encodeDynamicTable

46− (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr

47− writeIORef encodeDynamicTable ehdrtbl'

48− return builder

50----------------------------------------------------------------

40----------------------------------------------------------------

@@ -54,20 +44,6 @@ hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do

54 hdrtbl <- readIORef decodeDynamicTable

44 hdrtbl <- readIORef decodeDynamicTable

55 (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup

45 (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup

56 writeIORef decodeDynamicTable hdrtbl'

46 writeIORef decodeDynamicTable hdrtbl'

57− return $ concatCookie hdr

47+ return hdr

58 where

48 where

59 cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"

49 cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"

60−

61−-- |

62−--

63−-- >>> concatCookie [("foo","bar")]

64−-- [("foo","bar")]

65−-- >>> concatCookie [("cookie","a=b"),("foo","bar"),("cookie","c=d"),("cookie","e=f")]

66−-- [("foo","bar"),("cookie","a=b; c=d; e=f")]

67−concatCookie :: HeaderList -> HeaderList

68−concatCookie = collect []

69− where

70− collect cookies (("cookie",c):rest) = collect (cookies ++ [c]) rest

71− collect cookies (h:rest) = h : collect cookies rest

72− collect [] [] = []

73− collect cookies [] = [("cookie", B.intercalate "; " cookies)]

warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+7−8

@@ -56,7 +56,7 @@ frameReceiver ctx mkreq recvN = loop `E.catch` sendGoaway

56 cont <- processStreamGuardingError $ decodeFrameHeader hd

57 when cont loop

59− processStreamGuardingError (FrameHeaders, FrameHeader{streamId})

59+ processStreamGuardingError (_, FrameHeader{streamId})

60 | isResponse streamId = E.throwIO $ ConnectionError ProtocolError "stream id should be odd"

61 processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do

62 mx <- readIORef continued

@@ -161,15 +161,15 @@ frameReceiver ctx mkreq recvN = loop `E.catch` sendGoaway

161 -- idle, so that receiving frames on it is only a

162 -- stream error.

163 consume payloadLength

164− strm <- newStream concurrency streamId 0

164+ strm <- newStream streamId 0

165 writeIORef (streamState strm) $ Closed $

166 ResetByMe $ E.toException $

167 StreamError RefusedStream streamId

168 insert streamTable streamId strm

169 E.throwIO $ StreamError RefusedStream streamId

170 ws <- initialWindowSize <$> readIORef http2settings

171− newstrm <- newStream concurrency streamId (fromIntegral ws)

171+ newstrm <- newStream streamId (fromIntegral ws)

172− when (ftyp == FrameHeaders) $ opened newstrm

172+ when (ftyp == FrameHeaders) $ opened ctx newstrm

173 insert streamTable streamId newstrm

174 return newstrm

175

@@ -186,7 +186,7 @@ control FrameSettings header@FrameHeader{flags} bs Context{http2settings, output

186 unless (testAck flags) $ do

187 modifyIORef http2settings $ \old -> updateSettings old alist

188 let frame = settingsFrame setAck []

189− enqueueControl outputQ 0 $ OSettings frame alist

189+ enqueueControl outputQ 0 $ OFrame frame

190 return True

191

192control FramePing FrameHeader{flags} bs Context{outputQ} =

@@ -311,16 +311,15 @@ stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow

311 atomically $ writeTVar streamWindow w

312 return s

313

314−stream FrameRSTStream header bs _ _ strm = do

314+stream FrameRSTStream header bs ctx _ strm = do

315 RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs

316 let cc = Reset e

317− closed strm cc

317+ closed ctx strm cc

318 return $ Closed cc -- will be written to streamState again

319

320stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do

321 PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs

322 checkPriority newpri streamNumber

323− -- checkme: this should be tested

324 oldpre <- readIORef streamPrecedence

323 oldpre <- readIORef streamPrecedence

325 let !newpre = toPrecedence newpri

324 let !newpre = toPrecedence newpri

326 writeIORef streamPrecedence newpre

325 writeIORef streamPrecedence newpre

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

@@ -41,7 +41,7 @@ data ValidHeaders = ValidHeaders {

41 vhMethod :: ByteString

42 , vhPath :: ByteString

43 , vhAuth :: Maybe ByteString

44− , vhCL :: Maybe Int -- ^ Content-Length

44+ , vhCL :: Maybe Int

45 , vhHeader :: RequestHeaders

46 }

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+239−235

@@ -7,71 +7,55 @@ module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where

7#if __GLASGOW_HASKELL__ < 709

8import Control.Applicative

9#endif

10−import Control.Concurrent.MVar (putMVar)

11import Control.Concurrent.STM

10import Control.Concurrent.STM

12import qualified Control.Exception as E

11import qualified Control.Exception as E

13−import Control.Monad (void, when)

12+import Control.Monad (unless, void, when)

14import qualified Data.ByteString as BS

13import qualified Data.ByteString as BS

15−import qualified Data.ByteString.Builder as B (int32BE)

16import qualified Data.ByteString.Builder.Extra as B

14import qualified Data.ByteString.Builder.Extra as B

17−import Data.Monoid ((<>))

18import Foreign.Ptr

15import Foreign.Ptr

19−import qualified Network.HTTP.Types as H

20−import Network.HPACK (setLimitForEncoding)

21import Network.HTTP2

16import Network.HTTP2

22import Network.HTTP2.Priority

17import Network.HTTP2.Priority

23−import Network.Wai (FilePart(..))

18+import Network.Wai

24−import Network.Wai.HTTP2 (Trailers, promiseHeaders)

25import Network.Wai.Handler.Warp.Buffer

19import Network.Wai.Handler.Warp.Buffer

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

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

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

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

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

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

29import Network.Wai.Handler.Warp.IORef

23import Network.Wai.Handler.Warp.IORef

30import qualified Network.Wai.Handler.Warp.Settings as S

24import qualified Network.Wai.Handler.Warp.Settings as S

25+import qualified Network.Wai.Handler.Warp.Timeout as T

31import Network.Wai.Handler.Warp.Types

26import Network.Wai.Handler.Warp.Types

27+import Network.Wai.Internal (Response(..))

28+import qualified System.PosixCompat.Files as P

33#ifdef WINDOWS

30#ifdef WINDOWS

34import qualified System.IO as IO

31import qualified System.IO as IO

35#else

32#else

36−import Network.Wai.Handler.Warp.FdCache (getFd)

33+import Network.Wai.Handler.Warp.FdCache

37import Network.Wai.Handler.Warp.SendFile (positionRead)

34import Network.Wai.Handler.Warp.SendFile (positionRead)

38−import qualified Network.Wai.Handler.Warp.Timeout as T

39import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)

35import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)

40−import System.Posix.Types (Fd)

36+import System.Posix.Types

41#endif

37#endif

43----------------------------------------------------------------

39----------------------------------------------------------------

45−-- | The platform-specific type of an open file to stream from. On Windows we

46−-- don't have pread, so this is just a Handle; on Unix platforms with pread,

47−-- this is a file descriptor supplied by the fd cache.

48−#ifdef WINDOWS

49−type OpenFile = IO.Handle

50−#else

51−type OpenFile = Fd

52−#endif

53−

54data Leftover = LZero

41data Leftover = LZero

55 | LOne B.BufferWriter

42 | LOne B.BufferWriter

56 | LTwo BS.ByteString B.BufferWriter

43 | LTwo BS.ByteString B.BufferWriter

57− | LFile OpenFile Integer Integer (IO ())

59----------------------------------------------------------------

45----------------------------------------------------------------

61−-- | Run the given action if the stream is not closed; handle any exceptions by

62−-- resetting the stream.

63−unlessClosed :: Connection -> Stream -> IO () -> IO Bool

47+unlessClosed :: Context -> Connection -> Stream -> IO () -> IO ()

48+unlessClosed ctx

64−unlessClosed Connection{connSendAll}

49+ Connection{connSendAll}

65 strm@Stream{streamState,streamNumber}

50 strm@Stream{streamState,streamNumber}

66 body = E.handle resetStream $ do

51 body = E.handle resetStream $ do

67 state <- readIORef streamState

52 state <- readIORef streamState

68− if (isClosed state) then return False else body >> return True

53+ unless (isClosed state) body

69 where

54 where

70 resetStream e = do

55 resetStream e = do

71− closed strm (ResetByMe e)

56+ closed ctx strm (ResetByMe e)

72 let rst = resetFrame InternalError streamNumber

57 let rst = resetFrame InternalError streamNumber

73 connSendAll rst

58 connSendAll rst

74− return False

76getWindowSize :: TVar WindowSize -> TVar WindowSize -> IO WindowSize

60getWindowSize :: TVar WindowSize -> TVar WindowSize -> IO WindowSize

77getWindowSize connWindow strmWindow = do

61getWindowSize connWindow strmWindow = do

@@ -85,7 +69,7 @@ getWindowSize connWindow strmWindow = do

85 return $ min cw sw

69 return $ min cw sw

87frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO ()

71frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO ()

88−frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}

72+frameSender ctx@Context{outputQ,connectionWindow}

89 conn@Connection{connWriteBuffer,connBufferSize,connSendAll}

73 conn@Connection{connWriteBuffer,connBufferSize,connSendAll}

90 ii settings = go `E.catch` ignore

74 ii settings = go `E.catch` ignore

91 where

75 where

@@ -106,112 +90,69 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}

106

107 switch OFinish _ = return ()

91 switch OFinish _ = return ()

108 switch (OGoaway frame) _ = connSendAll frame

92 switch (OGoaway frame) _ = connSendAll frame

109− switch (OSettings frame alist) _ = do

110− connSendAll frame

111− case lookup SettingsHeaderTableSize alist of

112− Nothing -> return ()

113− Just siz -> do

114− dyntbl <- readIORef encodeDynamicTable

115− setLimitForEncoding siz dyntbl

116− loop

117 switch (OFrame frame) _ = do

93 switch (OFrame frame) _ = do

118 connSendAll frame

94 connSendAll frame

119 loop

95 loop

120− switch (OResponse strm s h aux) pre = do

96+ switch (OResponse strm rsp aux) pre = do

121− writeIORef (streamPrecedence strm) pre -- fixme

97+ writeIORef (streamPrecedence strm) pre

122− _ <- unlessClosed conn strm $

98+ unlessClosed ctx conn strm $ do

123− getWindowSize connectionWindow (streamWindow strm) >>=

99+ lim <- getWindowSize connectionWindow (streamWindow strm)

124− sendResponse strm s h aux

100+ -- Header frame and Continuation frame

101+ let sid = streamNumber strm

102+ endOfStream = case aux of

103+ Persist{} -> False

104+ Oneshot hb -> not hb

105+ len <- headerContinue sid rsp endOfStream

106+ let total = len + frameHeaderLength

107+ case aux of

108+ Oneshot True -> do -- hasBody

109+ -- Data frame payload

110+ (off, _) <- sendHeadersIfNecessary total

111+ let payloadOff = off + frameHeaderLength

112+ Next datPayloadLen mnext <-

113+ fillResponseBodyGetNext conn ii payloadOff lim rsp

114+ fillDataHeaderSend strm total datPayloadLen mnext

115+ maybeEnqueueNext strm mnext

116+ Oneshot False -> do

117+ -- "closed" must be before "connSendAll". If not,

118+ -- the context would be switched to the receiver,

119+ -- resulting the inconsistency of concurrency.

120+ closed ctx strm Finished

121+ flushN total

122+ Persist sq tvar -> do

123+ (off, needSend) <- sendHeadersIfNecessary total

124+ let payloadOff = off + frameHeaderLength

125+ Next datPayloadLen mnext <-

126+ fillStreamBodyGetNext conn payloadOff lim sq tvar strm

127+ -- If no data was immediately available, avoid sending an

128+ -- empty data frame.

129+ if datPayloadLen > 0 then

130+ fillDataHeaderSend strm total datPayloadLen mnext

131+ else

132+ when needSend $ flushN off

133+ maybeEnqueueNext strm mnext

125 loop

134 loop

126 switch (ONext strm curr) pre = do

135 switch (ONext strm curr) pre = do

127 writeIORef (streamPrecedence strm) pre

136 writeIORef (streamPrecedence strm) pre

128− _ <- unlessClosed conn strm $ do

137+ unlessClosed ctx conn strm $ do

129 lim <- getWindowSize connectionWindow (streamWindow strm)

138 lim <- getWindowSize connectionWindow (streamWindow strm)

130 -- Data frame payload

139 -- Data frame payload

131 Next datPayloadLen mnext <- curr lim

140 Next datPayloadLen mnext <- curr lim

132− fillDataHeaderSend strm 0 datPayloadLen

141+ fillDataHeaderSend strm 0 datPayloadLen mnext

133− dispatchNext strm mnext

142+ maybeEnqueueNext strm mnext

134− loop

135− switch (OPush oldStrm push mvar strm s h aux) pre = do

136− writeIORef (streamPrecedence strm) pre -- fixme

137− pushed <- unlessClosed conn oldStrm $ do

138− lim <- getWindowSize connectionWindow (streamWindow strm)

139− -- Write and send the promise.

140− builder <- hpackEncodeCIHeaders ctx $ promiseHeaders push

141− off <- pushContinue (streamNumber oldStrm) (streamNumber strm) builder

142− flushN $ off + frameHeaderLength

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

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

145− sendResponse strm s h aux lim

146− putMVar mvar pushed

147 loop

143 loop

148

144

149− -- Send the response headers and as much of the response as is immediately

150− -- available; shared by normal responses and pushed streams.

151− sendResponse :: Stream -> H.Status -> H.ResponseHeaders -> Aux -> WindowSize -> IO ()

152− sendResponse strm s h (Persist sq tvar) lim = do

153− -- Header frame and Continuation frame

154− let sid = streamNumber strm

155− builder <- hpackEncodeHeader ctx ii settings s h

156− len <- headerContinue sid builder False

157− let total = len + frameHeaderLength

158− (off, needSend) <- sendHeadersIfNecessary total

159− let payloadOff = off + frameHeaderLength

160− Next datPayloadLen mnext <-

161− fillStreamBodyGetNext ii conn payloadOff lim sq tvar strm

162− -- If no data was immediately available, avoid sending an

163− -- empty data frame.

164− if datPayloadLen > 0 then

165− fillDataHeaderSend strm total datPayloadLen

166− else

167− when needSend $ flushN off

168− dispatchNext strm mnext

169−

170− -- Send the stream's trailers and close the stream.

171− sendTrailers :: Stream -> Trailers -> IO ()

172− sendTrailers strm trailers = do

173− -- Trailers always indicate the end of a stream; send them in

174− -- consecutive header+continuation frames and end the stream. Some

175− -- clients dislike empty headers frames, so end the stream with an

176− -- empty data frame instead, as recommended by the spec.

177− toFlush <- case trailers of

178− [] -> frameHeaderLength <$ fillFrameHeader FrameData 0

179− (streamNumber strm)

180− (setEndStream defaultFlags)

181− connWriteBuffer

182− _ -> do

183− builder <- hpackEncodeCIHeaders ctx trailers

184− off <- headerContinue (streamNumber strm) builder True

185− return (off + frameHeaderLength)

186− -- 'closed' must be before 'flushN'. If not, the context would be

187− -- switched to the receiver, resulting in the inconsistency of

188− -- concurrency.

189− closed strm Finished

190− flushN toFlush

191−

192 -- Flush the connection buffer to the socket, where the first 'n' bytes of

145 -- Flush the connection buffer to the socket, where the first 'n' bytes of

193 -- the buffer are filled.

146 -- the buffer are filled.

194 flushN :: Int -> IO ()

147 flushN :: Int -> IO ()

195 flushN n = bufferIO connWriteBuffer n connSendAll

148 flushN n = bufferIO connWriteBuffer n connSendAll

196

149

197− -- A flags value with the end-header flag set iff the argument is B.Done.

198− maybeEndHeaders B.Done = setEndHeader defaultFlags

199− maybeEndHeaders _ = defaultFlags

200−

201− -- Write PUSH_PROMISE and possibly CONTINUATION frames into the connection

202− -- buffer, using the given builder as their contents; flush them to the

203− -- socket as necessary.

204− pushContinue sid newSid builder = do

205− let builder' = B.int32BE (fromIntegral newSid) <> builder

206− (len, signal) <- B.runBuilder builder' bufHeaderPayload headerPayloadLim

207− let flag = maybeEndHeaders signal

208− fillFrameHeader FramePushPromise len sid flag connWriteBuffer

209− continue sid len signal

210−

211− -- Write HEADER and possibly CONTINUATION frames.

212− headerContinue sid builder endOfStream = do

150+ headerContinue sid rsp endOfStream = do

151+ builder <- hpackEncodeHeader ctx ii settings rsp

213 (len, signal) <- B.runBuilder builder bufHeaderPayload headerPayloadLim

152 (len, signal) <- B.runBuilder builder bufHeaderPayload headerPayloadLim

214− let flag0 = maybeEndHeaders signal

153+ let flag0 = case signal of

154+ B.Done -> setEndHeader defaultFlags

155+ _ -> defaultFlags

215 flag = if endOfStream then setEndStream flag0 else flag0

156 flag = if endOfStream then setEndStream flag0 else flag0

216 fillFrameHeader FrameHeaders len sid flag connWriteBuffer

157 fillFrameHeader FrameHeaders len sid flag connWriteBuffer

217 continue sid len signal

158 continue sid len signal

@@ -220,7 +161,9 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}

220 continue sid len (B.More _ writer) = do

161 continue sid len (B.More _ writer) = do

221 flushN $ len + frameHeaderLength

162 flushN $ len + frameHeaderLength

222 (len', signal') <- writer bufHeaderPayload headerPayloadLim

163 (len', signal') <- writer bufHeaderPayload headerPayloadLim

223− let flag = maybeEndHeaders signal'

164+ let flag = case signal' of

165+ B.Done -> setEndHeader defaultFlags

166+ _ -> defaultFlags

224 fillFrameHeader FrameContinuation len' sid flag connWriteBuffer

167 fillFrameHeader FrameContinuation len' sid flag connWriteBuffer

225 continue sid len' signal'

168 continue sid len' signal'

226 continue sid len (B.Chunk bs writer) = do

169 continue sid len (B.Chunk bs writer) = do

@@ -237,22 +180,16 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}

237 -- True if the connection buffer has room for a 1-byte data frame.

180 -- True if the connection buffer has room for a 1-byte data frame.

238 canFitDataFrame total = total + frameHeaderLength < connBufferSize

181 canFitDataFrame total = total + frameHeaderLength < connBufferSize

239

182

240− -- Take the appropriate action based on the given 'Control':

183+ -- Re-enqueue the stream in the output queue if more output is immediately

241− -- - If more output is immediately available, re-enqueue the stream in the

242− -- output queue.

243− -- - If the output is over and trailers are available, send them now and

244− -- end the stream.

245− -- - If we've drained the queue and handed the stream back to its waiter,

246− -- do nothing.

184+ -- available; do nothing otherwise.

247− --

248− -- This is done after sending any part of the stream body, so it's shared

249− -- by 'sendResponse' and @switch (ONext ...)@.

250− dispatchNext :: Stream -> Control DynaNext -> IO ()

185+ maybeEnqueueNext :: Stream -> Control DynaNext -> IO ()

251− dispatchNext _ CNone = return ()

252− dispatchNext strm (CFinish trailers) = sendTrailers strm trailers

253− dispatchNext strm (CNext next) = do

186+ maybeEnqueueNext strm (CNext next) = do

254 let out = ONext strm next

187 let out = ONext strm next

255 enqueueOrSpawnTemporaryWaiter strm outputQ out

188 enqueueOrSpawnTemporaryWaiter strm outputQ out

189+ -- If the streaming is not finished, it must already have been

190+ -- written to the 'TVar' owned by 'waiter', which will

191+ -- put it back into the queue when more output becomes available.

192+ maybeEnqueueNext _ _ = return ()

256

193

257

194

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

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

@@ -264,12 +201,21 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}

264 flushN total

201 flushN total

265 return (0, False)

202 return (0, False)

266

203

267− fillDataHeaderSend strm otherLen datPayloadLen = do

204+ fillDataHeaderSend strm otherLen datPayloadLen mnext = do

268 -- Data frame header

205 -- Data frame header

269 let sid = streamNumber strm

206 let sid = streamNumber strm

270 buf = connWriteBuffer `plusPtr` otherLen

207 buf = connWriteBuffer `plusPtr` otherLen

271 total = otherLen + frameHeaderLength + datPayloadLen

208 total = otherLen + frameHeaderLength + datPayloadLen

209+ flag = case mnext of

210+ CFinish -> setEndStream defaultFlags

211+ _ -> defaultFlags

272− fillFrameHeader FrameData datPayloadLen sid defaultFlags buf

212+ fillFrameHeader FrameData datPayloadLen sid flag buf

213+ -- "closed" must be before "connSendAll". If not,

214+ -- the context would be switched to the receiver,

215+ -- resulting the inconsistency of concurrency.

216+ case mnext of

217+ CFinish -> closed ctx strm Finished

218+ _ -> return ()

273 flushN total

219 flushN total

274 atomically $ do

220 atomically $ do

275 modifyTVar' connectionWindow (subtract datPayloadLen)

221 modifyTVar' connectionWindow (subtract datPayloadLen)

@@ -281,108 +227,130 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}

281

227

282----------------------------------------------------------------

228----------------------------------------------------------------

283

229

284−fillStreamBodyGetNext :: InternalInfo -> Connection -> Int -> WindowSize

230+{-

285− -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next

231+ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

232+ResponseBuilder Status ResponseHeaders Builder

233+ResponseStream Status ResponseHeaders StreamingBody

234+ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response

235+-}

236+

237+fillResponseBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Response -> IO Next

286−fillStreamBodyGetNext ii Connection{connWriteBuffer,connBufferSize}

238+fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}

287− off lim sq tvar strm = do

239+ _ off lim (ResponseBuilder _ _ bb) = do

288 let datBuf = connWriteBuffer `plusPtr` off

240 let datBuf = connWriteBuffer `plusPtr` off

289 room = min (connBufferSize - off) lim

241 room = min (connBufferSize - off) lim

290− (leftover, cont, len) <- runStreamBuilder ii datBuf room sq

242+ (len, signal) <- B.runBuilder bb datBuf room

291− nextForStream ii connWriteBuffer connBufferSize sq tvar strm leftover cont len

243+ return $ nextForBuilder connWriteBuffer connBufferSize len signal

292−

293−----------------------------------------------------------------

294−

295−runStreamBuilder :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence

296− -> IO (Leftover, Maybe Trailers, BytesFilled)

297−runStreamBuilder ii buf0 room0 sq = loop buf0 room0 0

298− where

299− loop !buf !room !total = do

300− mbuilder <- atomically $ tryReadTBQueue sq

301− case mbuilder of

302− Nothing -> return (LZero, Nothing, total)

303− Just (SBuilder builder) -> do

304− (len, signal) <- B.runBuilder builder buf room

305− let !total' = total + len

306− case signal of

307− B.Done -> loop (buf `plusPtr` len) (room - len) total'

308− B.More _ writer -> return (LOne writer, Nothing, total')

309− B.Chunk bs writer -> return (LTwo bs writer, Nothing, total')

310− Just (SFile path part) -> do

311− (leftover, len) <- runStreamFile ii buf room path part

312− let !total' = total + len

313− case leftover of

314− LZero -> loop (buf `plusPtr` len) (room - len) total'

315− _ -> return (leftover, Nothing, total')

316−

317− Just SFlush -> return (LZero, Nothing, total)

318− Just (SFinish trailers) -> return (LZero, Just trailers, total)

319−

320−-- | Open the file and start reading into the send buffer.

321−runStreamFile :: InternalInfo -> Buffer -> BufSize -> FilePath -> FilePart

322− -> IO (Leftover, BytesFilled)

323−

324−-- | Read the given (OS-specific) file representation into the buffer. On

325−-- non-Windows systems this uses pread; on Windows this ignores the position

326−-- because we use the Handle's internal read position instead (because it's not

327−-- potentially shared with other readers).

328−readOpenFile :: OpenFile -> Buffer -> BufSize -> Integer -> IO Int

329

244

330#ifdef WINDOWS

245#ifdef WINDOWS

331−runStreamFile _ buf room path part = do

246+fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}

332− let start = filePartOffset part

247+ _ off lim (ResponseFile _ _ path mpart) = do

333− bytes = filePartByteCount part

248+ let datBuf = connWriteBuffer `plusPtr` off

249+ room = min (connBufferSize - off) lim

250+ (start, bytes) <- fileStartEnd path mpart

334 -- fixme: how to close Handle? GC does it at this moment.

251 -- fixme: how to close Handle? GC does it at this moment.

335 h <- IO.openBinaryFile path IO.ReadMode

252 h <- IO.openBinaryFile path IO.ReadMode

336 IO.hSeek h IO.AbsoluteSeek start

253 IO.hSeek h IO.AbsoluteSeek start

337− fillBufFile buf room h start bytes (return ())

338−

339−readOpenFile h buf room _ = IO.hGetBufSome h buf room

254+ len <- IO.hGetBufSome h datBuf (mini room bytes)

255+ let bytes' = bytes - fromIntegral len

256+ return $ nextForFile len connWriteBuffer connBufferSize h bytes' (return ())

340#else

257#else

341−runStreamFile ii buf room path part = do

258+fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}

342− let start = filePartOffset part

259+ ii off lim (ResponseFile _ _ path mpart) = do

343− bytes = filePartByteCount part

344 (fd, refresh) <- case fdCacher ii of

260 (fd, refresh) <- case fdCacher ii of

345 Just fdcache -> getFd fdcache path

261 Just fdcache -> getFd fdcache path

346 Nothing -> do

262 Nothing -> do

347 fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}

263 fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}

348 th <- T.register (timeoutManager ii) (closeFd fd')

264 th <- T.register (timeoutManager ii) (closeFd fd')

349 return (fd', T.tickle th)

265 return (fd', T.tickle th)

350− fillBufFile buf room fd start bytes refresh

266+ let datBuf = connWriteBuffer `plusPtr` off

351−

267+ room = min (connBufferSize - off) lim

352−readOpenFile = positionRead

268+ (start, bytes) <- fileStartEnd path mpart

353−#endif

354−

355−-- | Read as much of the file as is currently available into the buffer, then

356−-- return a 'Leftover' to indicate whether this file chunk has more data to

357−-- send. If this read hit the end of the file range, return 'LZero'; otherwise

358−-- return 'LFile' so this stream will continue reading from the file the next

359−-- time it's pulled from the queue.

360−fillBufFile :: Buffer -> BufSize -> OpenFile -> Integer -> Integer -> (IO ())

361− -> IO (Leftover, BytesFilled)

362−fillBufFile buf room f start bytes refresh = do

363− len <- readOpenFile f buf (mini room bytes) start

269+ len <- positionRead fd datBuf (mini room bytes) start

364 refresh

270 refresh

365 let len' = fromIntegral len

271 let len' = fromIntegral len

366− leftover = if bytes > len' then

367− LFile f (start + len') (bytes - len') refresh

272+ return $ nextForFile len connWriteBuffer connBufferSize fd (start + len') (bytes - len') refresh

368− else

273+#endif

369− LZero

370− return (leftover, len)

371

274

372−mini :: Int -> Integer -> Int

275+fillResponseBodyGetNext _ _ _ _ _ = error "fillResponseBodyGetNext"

373−mini i n

276+

277+fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)

278+fileStartEnd path Nothing = do

374− | fromIntegral i < n = i

279+ end <- fromIntegral . P.fileSize <$> P.getFileStatus path

280+ return (0, end)

281+fileStartEnd _ (Just part) =

282+ return (filePartOffset part, filePartByteCount part)

283+

284+----------------------------------------------------------------

285+

286+fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next

287+fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

288+ off lim sq tvar strm = do

289+ let datBuf = connWriteBuffer `plusPtr` off

290+ room = min (connBufferSize - off) lim

291+ (leftover, cont, len) <- runStreamBuilder datBuf room sq

292+ nextForStream connWriteBuffer connBufferSize sq tvar strm leftover cont len

293+

294+----------------------------------------------------------------

295+

296+fillBufBuilder :: Buffer -> BufSize -> Leftover -> DynaNext

297+fillBufBuilder buf0 siz0 leftover lim = do

298+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

299+ room = min (siz0 - frameHeaderLength) lim

300+ case leftover of

301+ LZero -> error "fillBufBuilder: LZero"

302+ LOne writer -> do

303+ (len, signal) <- writer payloadBuf room

304+ getNext len signal

305+ LTwo bs writer

306+ | BS.length bs <= room -> do

307+ buf1 <- copy payloadBuf bs

308+ let len1 = BS.length bs

309+ (len2, signal) <- writer buf1 (room - len1)

310+ getNext (len1 + len2) signal

375− | otherwise = fromIntegral n

311+ | otherwise -> do

312+ let (bs1,bs2) = BS.splitAt room bs

313+ void $ copy payloadBuf bs1

314+ getNext room (B.Chunk bs2 writer)

315+ where

316+ getNext l s = return $ nextForBuilder buf0 siz0 l s

317+

318+nextForBuilder :: Buffer -> BufSize -> BytesFilled -> B.Next -> Next

319+nextForBuilder _ _ len B.Done

320+ = Next len CFinish

321+nextForBuilder buf siz len (B.More _ writer)

322+ = Next len (CNext (fillBufBuilder buf siz (LOne writer)))

323+nextForBuilder buf siz len (B.Chunk bs writer)

324+ = Next len (CNext (fillBufBuilder buf siz (LTwo bs writer)))

325+

326+----------------------------------------------------------------

327+

328+runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence

329+ -> IO (Leftover, Bool, BytesFilled)

330+runStreamBuilder buf0 room0 sq = loop buf0 room0 0

331+ where

332+ loop !buf !room !total = do

333+ mbuilder <- atomically $ tryReadTBQueue sq

334+ case mbuilder of

335+ Nothing -> return (LZero, True, total)

336+ Just (SBuilder builder) -> do

337+ (len, signal) <- B.runBuilder builder buf room

338+ let !total' = total + len

339+ case signal of

340+ B.Done -> loop (buf `plusPtr` len) (room - len) total'

341+ B.More _ writer -> return (LOne writer, True, total')

342+ B.Chunk bs writer -> return (LTwo bs writer, True, total')

343+ Just SFlush -> return (LZero, True, total)

344+ Just SFinish -> return (LZero, False, total)

376

345

377−fillBufStream :: InternalInfo -> Buffer -> BufSize -> Leftover

378− -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext

346+fillBufStream :: Buffer -> BufSize -> Leftover -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext

379−fillBufStream ii buf0 siz0 leftover0 sq tvar strm lim0 = do

347+fillBufStream buf0 siz0 leftover0 sq tvar strm lim0 = do

380 let payloadBuf = buf0 `plusPtr` frameHeaderLength

348 let payloadBuf = buf0 `plusPtr` frameHeaderLength

381 room0 = min (siz0 - frameHeaderLength) lim0

349 room0 = min (siz0 - frameHeaderLength) lim0

382 case leftover0 of

350 case leftover0 of

383 LZero -> do

351 LZero -> do

384− (leftover, end, len) <- runStreamBuilder ii payloadBuf room0 sq

352+ (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq

385− getNext leftover end len

353+ getNext leftover cont len

386 LOne writer -> write writer payloadBuf room0 0

354 LOne writer -> write writer payloadBuf room0 0

387 LTwo bs writer

355 LTwo bs writer

388 | BS.length bs <= room0 -> do

356 | BS.length bs <= room0 -> do

@@ -392,35 +360,71 @@ fillBufStream ii buf0 siz0 leftover0 sq tvar strm lim0 = do

392 | otherwise -> do

360 | otherwise -> do

393 let (bs1,bs2) = BS.splitAt room0 bs

361 let (bs1,bs2) = BS.splitAt room0 bs

394 void $ copy payloadBuf bs1

362 void $ copy payloadBuf bs1

395− getNext (LTwo bs2 writer) Nothing room0

363+ getNext (LTwo bs2 writer) True room0

396− LFile fd start bytes refresh -> do

397− (leftover, len) <- fillBufFile payloadBuf room0 fd start bytes refresh

398− getNext leftover Nothing len

399 where

364 where

400− getNext = nextForStream ii buf0 siz0 sq tvar strm

365+ getNext = nextForStream buf0 siz0 sq tvar strm

401 write writer1 buf room sofar = do

366 write writer1 buf room sofar = do

402 (len, signal) <- writer1 buf room

367 (len, signal) <- writer1 buf room

403 case signal of

368 case signal of

404 B.Done -> do

369 B.Done -> do

405− (leftover, end, extra) <- runStreamBuilder ii (buf `plusPtr` len) (room - len) sq

370+ (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq

406 let !total = sofar + len + extra

371 let !total = sofar + len + extra

407− getNext leftover end total

372+ getNext leftover cont total

408 B.More _ writer -> do

373 B.More _ writer -> do

409 let !total = sofar + len

374 let !total = sofar + len

410− getNext (LOne writer) Nothing total

375+ getNext (LOne writer) True total

411 B.Chunk bs writer -> do

376 B.Chunk bs writer -> do

412 let !total = sofar + len

377 let !total = sofar + len

413− getNext (LTwo bs writer) Nothing total

378+ getNext (LTwo bs writer) True total

414−

379+

415−nextForStream :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence

380+nextForStream :: Buffer -> BufSize -> TBQueue Sequence -> TVar Sync -> Stream

416− -> TVar Sync -> Stream -> Leftover -> Maybe Trailers

417− -> BytesFilled -> IO Next

381+ -> Leftover -> Bool -> BytesFilled

382+ -> IO Next

418−nextForStream _ _ _ _ tvar _ _ (Just trailers) len = do

383+nextForStream _ _ _ tvar _ _ False len = do

419− atomically $ writeTVar tvar $ SyncFinish

384+ atomically $ writeTVar tvar SyncFinish

420− return $ Next len $ CFinish trailers

385+ return $ Next len CFinish

421−nextForStream ii buf siz sq tvar strm LZero Nothing len = do

386+nextForStream buf siz sq tvar strm LZero True len = do

422− let out = ONext strm (fillBufStream ii buf siz LZero sq tvar strm)

387+ let out = ONext strm (fillBufStream buf siz LZero sq tvar strm)

423 atomically $ writeTVar tvar $ SyncNext out

388 atomically $ writeTVar tvar $ SyncNext out

424 return $ Next len CNone

389 return $ Next len CNone

425−nextForStream ii buf siz sq tvar strm leftover Nothing len =

390+nextForStream buf siz sq tvar strm leftover True len =

426− return $ Next len (CNext (fillBufStream ii buf siz leftover sq tvar strm))

391+ return $ Next len (CNext (fillBufStream buf siz leftover sq tvar strm))

392+

393+----------------------------------------------------------------

394+

395+#ifdef WINDOWS

396+fillBufFile :: Buffer -> BufSize -> IO.Handle -> Integer -> IO () -> DynaNext

397+fillBufFile buf siz h bytes refresh lim = do

398+ let payloadBuf = buf `plusPtr` frameHeaderLength

399+ room = min (siz - frameHeaderLength) lim

400+ len <- IO.hGetBufSome h payloadBuf room

401+ refresh

402+ let bytes' = bytes - fromIntegral len

403+ return $ nextForFile len buf siz h bytes' refresh

404+

405+nextForFile :: BytesFilled -> Buffer -> BufSize -> IO.Handle -> Integer -> IO () -> Next

406+nextForFile 0 _ _ _ _ _ = Next 0 CFinish

407+nextForFile len _ _ _ 0 _ = Next len CFinish

408+nextForFile len buf siz h bytes refresh =

409+ Next len (CNext (fillBufFile buf siz h bytes refresh))

410+#else

411+fillBufFile :: Buffer -> BufSize -> Fd -> Integer -> Integer -> IO () -> DynaNext

412+fillBufFile buf siz fd start bytes refresh lim = do

413+ let payloadBuf = buf `plusPtr` frameHeaderLength

414+ room = min (siz - frameHeaderLength) lim

415+ len <- positionRead fd payloadBuf (mini room bytes) start

416+ let len' = fromIntegral len

417+ refresh

418+ return $ nextForFile len buf siz fd (start + len') (bytes - len') refresh

419+

420+nextForFile :: BytesFilled -> Buffer -> BufSize -> Fd -> Integer -> Integer -> IO () -> Next

421+nextForFile 0 _ _ _ _ _ _ = Next 0 CFinish

422+nextForFile len _ _ _ _ 0 _ = Next len CFinish

423+nextForFile len buf siz fd start bytes refresh =

424+ Next len (CNext (fillBufFile buf siz fd start bytes refresh))

425+#endif

426+

427+mini :: Int -> Integer -> Int

428+mini i n

429+ | fromIntegral i < n = i

430+ | otherwise = fromIntegral n

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+26−78

@@ -5,10 +5,9 @@ module Network.Wai.Handler.Warp.HTTP2.Types where

6import Data.ByteString.Builder (Builder)

7#if __GLASGOW_HASKELL__ < 709

8−import Control.Applicative ((<$>), (<*>), pure)

8+import Control.Applicative ((<$>),(<*>))

9#endif

10import Control.Concurrent (forkIO)

11−import Control.Concurrent.MVar (MVar)

12import Control.Concurrent.STM

11import Control.Concurrent.STM

13import Control.Exception (SomeException)

12import Control.Exception (SomeException)

14import Control.Monad (void)

13import Control.Monad (void)

@@ -18,8 +17,7 @@ import qualified Data.ByteString as BS

18import Data.IntMap.Strict (IntMap, IntMap)

17import Data.IntMap.Strict (IntMap, IntMap)

19import qualified Data.IntMap.Strict as M

18import qualified Data.IntMap.Strict as M

20import qualified Network.HTTP.Types as H

19import qualified Network.HTTP.Types as H

21−import Network.Wai (Request, FilePart)

20+import Network.Wai (Request, Response)

22−import Network.Wai.HTTP2 (PushPromise, Trailers)

23import Network.Wai.Handler.Warp.IORef

21import Network.Wai.Handler.Warp.IORef

24import Network.Wai.Handler.Warp.Types

22import Network.Wai.Handler.Warp.Types

@@ -38,7 +36,7 @@ isHTTP2 tls = useHTTP2

38 where

36 where

39 useHTTP2 = case tlsNegotiatedProtocol tls of

37 useHTTP2 = case tlsNegotiatedProtocol tls of

40 Nothing -> False

38 Nothing -> False

41− Just proto -> "h2-" `BS.isPrefixOf` proto || proto == "h2"

39+ Just proto -> "h2-" `BS.isPrefixOf` proto

43----------------------------------------------------------------

41----------------------------------------------------------------

@@ -46,21 +44,14 @@ data Input = Input Stream Request

47----------------------------------------------------------------

45----------------------------------------------------------------

49−-- | The result of writing data from a stream's queue into the buffer.

50−data Control a = CFinish Trailers

47+data Control a = CFinish

51− -- ^ The stream has ended, and the trailers should be sent.

52 | CNext a

48 | CNext a

53− -- ^ The stream has more data immediately available, and we

54− -- should re-enqueue it when the stream window becomes open.

55 | CNone

49 | CNone

56− -- ^ The stream queue has been drained and we've handed it off

57− -- to its dedicated waiter thread, which will re-enqueue it when

58− -- more data is available.

60instance Show (Control a) where

51instance Show (Control a) where

61− show (CFinish _) = "CFinish"

52+ show CFinish = "CFinish"

62− show (CNext _) = "CNext"

53+ show (CNext _) = "CNext"

63− show CNone = "CNone"

54+ show CNone = "CNone"

65type DynaNext = WindowSize -> IO Next

56type DynaNext = WindowSize -> IO Next

@@ -69,54 +60,28 @@ type BytesFilled = Int

69data Next = Next BytesFilled (Control DynaNext)

60data Next = Next BytesFilled (Control DynaNext)

71data Output = OFinish

62data Output = OFinish

72− -- ^ Terminate the connection.

73 | OGoaway ByteString

63 | OGoaway ByteString

74− -- ^ Send a goaway frame and terminate the connection.

75− | OSettings ByteString SettingsList

76− -- ^ Update settings and send an ack settings frame.

77 | OFrame ByteString

64 | OFrame ByteString

78− -- ^ Send an entire pre-encoded frame.

79− | OResponse Stream H.Status H.ResponseHeaders Aux

65+ | OResponse Stream Response Aux

80− -- ^ Send the headers and as much of the response as is immediately

81− -- available.

82− | OPush Stream PushPromise (MVar Bool) Stream H.Status H.ResponseHeaders Aux

83− -- ^ Send a PUSH_PROMISE frame, then act like OResponse; signal the

84− -- MVar whether the promise has been sent.

85 | ONext Stream DynaNext

66 | ONext Stream DynaNext

86− -- ^ Send a chunk of the response.

88outputStream :: Output -> Stream

68outputStream :: Output -> Stream

89−outputStream (OResponse strm _ _ _) = strm

69+outputStream (OResponse strm _ _) = strm

90−outputStream (ONext strm _) = strm

70+outputStream (ONext strm _) = strm

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

92−outputStream _ = error "outputStream"

71+outputStream _ = error "outputStream"

94----------------------------------------------------------------

73----------------------------------------------------------------

96−-- | An element on the queue between a running stream and the sender; the order

97−-- should consist of any number of 'SFile', 'SBuilder', and 'SFlush', followed

98−-- by a single 'SFinish'.

99−data Sequence = SFinish Trailers

75+data Sequence = SFinish

100− -- ^ The stream is over; its trailers are provided.

101 | SFlush

76 | SFlush

102− -- ^ Any buffered data should be sent immediately.

103 | SBuilder Builder

77 | SBuilder Builder

104− -- ^ Append a chunk of data to the stream.

105− | SFile FilePath FilePart

106− -- ^ Append a chunk of a file's contents to the stream.

107

108−-- | A message from the sender to a stream's dedicated waiter thread.

109data Sync = SyncNone

79data Sync = SyncNone

110− -- ^ Nothing interesting has happened. Go back to sleep.

111 | SyncFinish

80 | SyncFinish

112− -- ^ The stream has ended.

113 | SyncNext Output

81 | SyncNext Output

114− -- ^ The stream's queue has been drained; wait for more to be

115− -- available and re-enqueue the given 'Output'.

116

117−-- | Auxiliary information needed to communicate with a running stream: a queue

83+data Aux = Oneshot Bool

118−-- of stream elements ('Sequence') and a 'TVar' connected to its waiter thread.

119−data Aux = Persist (TBQueue Sequence) (TVar Sync)

84+ | Persist (TBQueue Sequence) (TVar Sync)

120

121----------------------------------------------------------------

86----------------------------------------------------------------

122

@@ -124,12 +89,7 @@ data Aux = Persist (TBQueue Sequence) (TVar Sync)

124data Context = Context {

89data Context = Context {

125 http2settings :: IORef Settings

90 http2settings :: IORef Settings

126 , streamTable :: StreamTable

91 , streamTable :: StreamTable

127− -- | Number of active streams initiated by the client; for enforcing our own

128− -- max concurrency setting.

129 , concurrency :: IORef Int

92 , concurrency :: IORef Int

130− -- | Number of active streams initiated by the server; for respecting the

131− -- client's max concurrency setting.

132− , pushConcurrency :: IORef Int

133 , priorityTreeSize :: IORef Int

93 , priorityTreeSize :: IORef Int

134 -- | RFC 7540 says "Other frames (from any stream) MUST NOT

94 -- | RFC 7540 says "Other frames (from any stream) MUST NOT

135 -- occur between the HEADERS frame and any CONTINUATION

95 -- occur between the HEADERS frame and any CONTINUATION

@@ -137,9 +97,6 @@ data Context = Context {

137 -- this requirement.

97 -- this requirement.

138 , continued :: IORef (Maybe StreamId)

98 , continued :: IORef (Maybe StreamId)

139 , currentStreamId :: IORef StreamId

99 , currentStreamId :: IORef StreamId

140− -- ^ Last client-initiated stream ID we've handled.

141− , nextPushStreamId :: IORef StreamId

142− -- ^ Next available server-initiated stream ID.

143 , inputQ :: TQueue Input

100 , inputQ :: TQueue Input

144 , outputQ :: PriorityTree Output

101 , outputQ :: PriorityTree Output

145 , encodeDynamicTable :: IORef DynamicTable

102 , encodeDynamicTable :: IORef DynamicTable

@@ -154,10 +111,8 @@ newContext = Context <$> newIORef defaultSettings

154 <*> initialize 10 -- fixme: hard coding: 10

111 <*> initialize 10 -- fixme: hard coding: 10

155 <*> newIORef 0

112 <*> newIORef 0

156 <*> newIORef 0

113 <*> newIORef 0

157− <*> newIORef 0

158 <*> newIORef Nothing

114 <*> newIORef Nothing

159 <*> newIORef 0

115 <*> newIORef 0

160− <*> newIORef 2 -- first server push stream; 0 is reserved

161 <*> newTQueueIO

116 <*> newTQueueIO

162 <*> newPriorityTree

117 <*> newPriorityTree

163 <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef)

118 <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef)

@@ -224,35 +179,28 @@ data Stream = Stream {

224 , streamBodyLength :: IORef Int

179 , streamBodyLength :: IORef Int

225 , streamWindow :: TVar WindowSize

180 , streamWindow :: TVar WindowSize

226 , streamPrecedence :: IORef Precedence

181 , streamPrecedence :: IORef Precedence

227− -- | The concurrency IORef in which this stream has been counted. The client

228− -- and server each have separate concurrency values to respect, so pushed

229− -- streams need to decrement a different count when they're closed. This

230− -- should be either @concurrency ctx@ or @pushConcurrency ctx@.

231− , concurrencyRef :: IORef Int

232 }

182 }

233

183

234instance Show Stream where

184instance Show Stream where

235 show s = show (streamNumber s)

185 show s = show (streamNumber s)

236

186

237−newStream :: IORef Int -> StreamId -> WindowSize -> IO Stream

187+newStream :: StreamId -> WindowSize -> IO Stream

238−newStream ref sid win =

239− Stream sid <$> newIORef Idle

188+newStream sid win = Stream sid <$> newIORef Idle

240− <*> newIORef Nothing

189+ <*> newIORef Nothing

241− <*> newIORef 0

190+ <*> newIORef 0

242− <*> newTVarIO win

191+ <*> newTVarIO win

243− <*> newIORef defaultPrecedence

192+ <*> newIORef defaultPrecedence

244− <*> pure ref

245

193

246----------------------------------------------------------------

194----------------------------------------------------------------

247

195

248−opened :: Stream -> IO ()

196+opened :: Context -> Stream -> IO ()

249−opened Stream{concurrencyRef,streamState} = do

197+opened Context{concurrency} Stream{streamState} = do

250− atomicModifyIORef' concurrencyRef (\x -> (x+1,()))

198+ atomicModifyIORef' concurrency (\x -> (x+1,()))

251 writeIORef streamState (Open JustOpened)

199 writeIORef streamState (Open JustOpened)

252

200

253−closed :: Stream -> ClosedCode -> IO ()

201+closed :: Context -> Stream -> ClosedCode -> IO ()

254−closed Stream{concurrencyRef,streamState} cc = do

202+closed Context{concurrency} Stream{streamState} cc = do

255− atomicModifyIORef' concurrencyRef (\x -> (x-1,()))

203+ atomicModifyIORef' concurrency (\x -> (x-1,()))

256 writeIORef streamState (Closed cc)

204 writeIORef streamState (Closed cc)

257

205

258----------------------------------------------------------------

206----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+63−154

@@ -1,11 +1,10 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE NamedFieldPuns #-}

4{-# LANGUAGE PatternGuards #-}

3{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE CPP #-}

4{-# LANGUAGE CPP #-}

7module Network.Wai.Handler.Warp.HTTP2.Worker (

6module Network.Wai.Handler.Warp.HTTP2.Worker (

8− Respond

7+ Responder

9 , response

8 , response

10 , worker

9 , worker

11 ) where

10 ) where

@@ -27,153 +26,65 @@ import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

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

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

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

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

29import Network.Wai.Handler.Warp.IORef

28import Network.Wai.Handler.Warp.IORef

30−import Network.Wai.HTTP2

29+import qualified Network.Wai.Handler.Warp.Response as R

31− ( Chunk(..)

32− , HTTP2Application

33− , PushPromise

34− , Responder(runResponder)

35− , RespondFunc

36− )

37import qualified Network.Wai.Handler.Warp.Settings as S

30import qualified Network.Wai.Handler.Warp.Settings as S

38import qualified Network.Wai.Handler.Warp.Timeout as T

31import qualified Network.Wai.Handler.Warp.Timeout as T

32+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))

40----------------------------------------------------------------

34----------------------------------------------------------------

42−-- | An 'HTTP2Application' takes a function of status, headers, trailers, and

36+-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.

43−-- body; this type implements that by currying some internal arguments.

37+-- This type implements the second argument (Response -> IO ResponseReceived)

44−--

38+-- with extra arguments.

45−-- The token type of the RespondFunc is set to be (). This is a bit

39+type Responder = ThreadContinue -> T.Handle -> Stream -> Request ->

46−-- anti-climactic, but the real benefit of the token type is that the

40+ Response -> IO ResponseReceived

47−-- application is forced to call the responder, and making it a boring type

41+

48−-- doesn't break that property.

49−--

50−-- This is the argument to a 'Responder'.

51−type Respond = IO () -> Stream -> RespondFunc ()

52−

53−-- | This function is passed to workers. They also pass responses from

42+-- | This function is passed to workers.

43+-- They also pass 'Response's from 'Application's to this function.

54−-- 'HTTP2Application's to this function. This function enqueues commands for

44+-- This function enqueues commands for the HTTP/2 sender.

55−-- the HTTP/2 sender.

56−response :: Context -> Manager -> ThreadContinue -> Respond

45+response :: Context -> Manager -> Responder

57−response ctx mgr tconf tickle strm s h strmbdy = do

46+response Context{outputQ} mgr tconf th strm req rsp = do

58− -- TODO(awpr) HEAD requests will still stream.

47+ case rsp of

59−

48+ ResponseStream _ _ strmbdy -> do

60− -- We must not exit this WAI application.

49+ -- We must not exit this WAI application.

61− -- If the application exits, streaming would be also closed.

50+ -- If the application exits, streaming would be also closed.

62− -- So, this work occupies this thread.

51+ -- So, this work occupies this thread.

63− --

52+ --

64− -- We need to increase the number of workers.

53+ -- We need to increase the number of workers.

65− myThreadId >>= replaceWithAction mgr

54+ myThreadId >>= replaceWithAction mgr

66− -- After this work, this thread stops to decrease the number of workers.

55+ -- After this work, this thread stops to decease

56+ -- the number of workers.

67− setThreadContinue tconf False

57+ setThreadContinue tconf False

68−

69− runStream ctx OResponse tickle strm s h strmbdy

70−

71−-- | Set up a waiter thread and run the stream body with functions to enqueue

72−-- 'Sequence's on the stream's queue.

73−runStream :: Context

74− -> (Stream -> H.Status -> H.ResponseHeaders -> Aux -> Output)

75− -> Respond

76−runStream Context{outputQ} mkOutput tickle strm s h strmbdy = do

77− -- Since 'Body' is loop, we cannot control it.

58+ -- Since 'StreamingBody' is loop, we cannot control it.

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

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

79− sq <- newTBQueueIO 10 -- fixme: hard coding: 10

60+ sq <- newTBQueueIO 10 -- fixme: hard coding: 10

80− tvar <- newTVarIO SyncNone

61+ tvar <- newTVarIO SyncNone

81− let out = mkOutput strm s h (Persist sq tvar)

62+ let out = OResponse strm rsp (Persist sq tvar)

82− -- Since we must not enqueue an empty queue to the priority

63+ -- Since we must not enqueue an empty queue to the priority

83− -- queue, we spawn a thread to ensure that the designated

64+ -- queue, we spawn a thread to ensure that the designated

84− -- queue is not empty.

65+ -- queue is not empty.

85− void $ forkIO $ waiter tvar sq strm outputQ

66+ void $ forkIO $ waiter tvar sq outputQ

86− atomically $ writeTVar tvar $ SyncNext out

67+ atomically $ writeTVar tvar (SyncNext out)

87− let write chunk = do

68+ let push b = do

88− atomically $ writeTBQueue sq $ case chunk of

69+ atomically $ writeTBQueue sq (SBuilder b)

89− BuilderChunk b -> SBuilder b

70+ T.tickle th

90− FileChunk path part -> SFile path part

91− tickle

92− flush = atomically $ writeTBQueue sq SFlush

71+ flush = atomically $ writeTBQueue sq SFlush

93− trailers <- strmbdy write flush

72+ strmbdy push flush

94− atomically $ writeTBQueue sq $ SFinish trailers

73+ atomically $ writeTBQueue sq SFinish

95−

74+ _ -> do

96−-- | Handle abnormal termination of a stream: mark it as closed, send a reset

75+ setThreadContinue tconf True

97−-- frame, and call the user's 'settingsOnException' handler if applicable.

76+ let hasBody = requestMethod req /= H.methodHead

98−cleanupStream :: Context -> S.Settings -> Stream -> Maybe Request -> Maybe SomeException -> IO ()

77+ && R.hasBody (responseStatus rsp)

99−cleanupStream Context{outputQ} set strm req me = do

78+ out = OResponse strm rsp (Oneshot hasBody)

100− closed strm Killed

79+ enqueueOrSpawnTemporaryWaiter strm outputQ out

101− let sid = streamNumber strm

80+ return ResponseReceived

102− frame = resetFrame InternalError sid

103− enqueueControl outputQ sid $ OFrame frame

104− case me of

105− Nothing -> return ()

106− Just e -> S.settingsOnException set req e

107−

108−-- | Push the given 'Responder' to the client if the settings allow it

109−-- (specifically 'enablePush' and 'maxConcurrentStreams'). Returns 'True' if

110−-- the stream was actually pushed.

111−--

112−-- This is the push function given to an 'HTTP2Application'.

113−pushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO Bool

114−pushResponder ctx set strm promise responder = do

115− let Context{ http2settings

116− , pushConcurrency

117− } = ctx

118− cnt <- readIORef pushConcurrency

119− settings <- readIORef http2settings

120− let enabled = enablePush settings

121− fits = maybe True (cnt <) $ maxConcurrentStreams settings

122− canPush = fits && enabled

123− if canPush then

124− actuallyPushResponder ctx set strm promise responder

125− else

126− return False

127−

128−-- | Set up a pushed stream and run the 'Responder' in its own thread. Waits

129−-- for the sender thread to handle the push request. This can fail to push the

130−-- stream and return 'False' if the sender dequeued the push request after the

131−-- associated stream was closed.

132−actuallyPushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO Bool

133−actuallyPushResponder ctx set strm promise responder = do

134− let Context{ http2settings

135− , nextPushStreamId

136− , pushConcurrency

137− , streamTable

138− } = ctx

139− -- Claim the next outgoing stream.

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

141− ws <- initialWindowSize <$> readIORef http2settings

142−

143− newStrm <- newStream pushConcurrency newSid ws

144− -- Section 5.3.5 of RFC 7540 defines the weight of push promise is 16.

145− -- But we need not to follow the spec. So, this value would change

146− -- if necessary.

147− writeIORef (streamPrecedence newStrm) $

148− toPrecedence $ defaultPriority { streamDependency = streamNumber strm }

149− opened newStrm

150− insert streamTable newSid newStrm

151−

152− -- Set up a channel for the sender to report back whether it pushed the

153− -- stream.

154− mvar <- newEmptyMVar

155−

156− let mkOutput = OPush strm promise mvar

157− tickle = return ()

158− respond = runStream ctx mkOutput

159−

160− -- TODO(awpr): synthesize a Request for 'settingsOnException'?

161− _ <- forkIO $ runResponder responder (respond tickle newStrm) `E.catch`

162− (cleanupStream ctx set strm Nothing . Just)

163−

164− takeMVar mvar

165

166data Break = Break deriving (Show, Typeable)

82data Break = Break deriving (Show, Typeable)

167

168instance Exception Break

84instance Exception Break

169

170−worker :: Context

86+worker :: Context -> S.Settings -> T.Manager -> Application -> Responder -> IO ()

171− -> S.Settings

172− -> T.Manager

173− -> HTTP2Application

174− -> (ThreadContinue -> Respond)

175− -> IO ()

176−worker ctx@Context{inputQ} set tm app respond = do

87+worker ctx@Context{inputQ,outputQ} set tm app responder = do

177 tid <- myThreadId

88 tid <- myThreadId

178 sinfo <- newStreamInfo

89 sinfo <- newStreamInfo

179 tcont <- newThreadContinue

90 tcont <- newThreadContinue

@@ -182,17 +93,15 @@ worker ctx@Context{inputQ} set tm app respond = do

182 where

93 where

183 go sinfo tcont th = do

94 go sinfo tcont th = do

184 setThreadContinue tcont True

95 setThreadContinue tcont True

185−

186 ex <- E.try $ do

96 ex <- E.try $ do

187 T.pause th

97 T.pause th

188 Input strm req <- atomically $ readTQueue inputQ

98 Input strm req <- atomically $ readTQueue inputQ

189 setStreamInfo sinfo strm req

99 setStreamInfo sinfo strm req

190 T.resume th

100 T.resume th

191 T.tickle th

101 T.tickle th

192− let responder = app req $ pushResponder ctx set strm

193− runResponder responder $ respond tcont (T.tickle th) strm

102+ app req $ responder tcont th strm req

194 cont1 <- case ex of

103 cont1 <- case ex of

195− Right () -> return True

104+ Right ResponseReceived -> return True

196 Left e@(SomeException _)

105 Left e@(SomeException _)

197 | Just Break <- E.fromException e -> do

106 | Just Break <- E.fromException e -> do

198 cleanup sinfo Nothing

107 cleanup sinfo Nothing

@@ -211,16 +120,16 @@ worker ctx@Context{inputQ} set tm app respond = do

211 case m of

120 case m of

212 Nothing -> return ()

121 Nothing -> return ()

213 Just (strm,req) -> do

122 Just (strm,req) -> do

214− cleanupStream ctx set strm (Just req) me

123+ closed ctx strm Killed

124+ let frame = resetFrame InternalError (streamNumber strm)

125+ enqueueControl outputQ 0 (OFrame frame)

126+ case me of

127+ Nothing -> return ()

128+ Just e -> S.settingsOnException set (Just req) e

215 clearStreamInfo sinfo

129 clearStreamInfo sinfo

216

130

217−-- | A dedicated waiter thread to re-enqueue the stream in the priority tree

218−-- whenever output becomes available. When the sender drains the queue and

219−-- moves on to another stream, it drops a message in the 'TVar', and this

220−-- thread wakes up, waits for more output to become available, and re-enqueues

221−-- the stream.

222−waiter :: TVar Sync -> TBQueue Sequence -> Stream -> PriorityTree Output -> IO ()

131+waiter :: TVar Sync -> TBQueue Sequence -> PriorityTree Output -> IO ()

223−waiter tvar sq strm outQ = do

132+waiter tvar sq outQ = do

224 -- waiting for actions other than SyncNone

133 -- waiting for actions other than SyncNone

225 mx <- atomically $ do

134 mx <- atomically $ do

226 mout <- readTVar tvar

135 mout <- readTVar tvar

@@ -231,7 +140,7 @@ waiter tvar sq strm outQ = do

231 return $ Just out

140 return $ Just out

232 SyncFinish -> return Nothing

141 SyncFinish -> return Nothing

233 case mx of

142 case mx of

234− Nothing -> return ()

143+ Nothing -> return ()

235 Just out -> do

144 Just out -> do

236 -- ensuring that the streaming queue is not empty.

145 -- ensuring that the streaming queue is not empty.

237 atomically $ do

146 atomically $ do

@@ -239,14 +148,14 @@ waiter tvar sq strm outQ = do

239 when isEmpty retry

148 when isEmpty retry

240 -- ensuring that stream window is greater than 0.

149 -- ensuring that stream window is greater than 0.

241 enqueueWhenWindowIsOpen outQ out

150 enqueueWhenWindowIsOpen outQ out

242− waiter tvar sq strm outQ

151+ waiter tvar sq outQ

243

152

244----------------------------------------------------------------

153----------------------------------------------------------------

245

154

246-- | It would nice if responders could return values to workers.

155-- | It would nice if responders could return values to workers.

247-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.

156-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.

248-- It is not wise to change this type.

157-- It is not wise to change this type.

249−-- So, a reference is shared by a 'Respond' and its worker.

158+-- So, a reference is shared by a responder and its worker.

250-- The reference refers a value of this type as a return value.

159-- The reference refers a value of this type as a return value.

251-- If 'True', the worker continue to serve requests.

160-- If 'True', the worker continue to serve requests.

252-- Otherwise, the worker get finished.

161-- Otherwise, the worker get finished.

warp/Network/Wai/Handler/Warp/Internal.hs−11

@@ -8,18 +8,7 @@ module Network.Wai.Handler.Warp.Internal (

8 , runSettingsConnection

9 , runSettingsConnectionMaker

10 , runSettingsConnectionMakerSecure

11− , runServe

12− , runServeEnv

13− , runServeSettings

14− , runServeSettingsSocket

15− , runServeSettingsConnection

16− , runServeSettingsConnectionMaker

17− , runServeSettingsConnectionMakerSecure

18 , Transport (..)

11 , Transport (..)

19− -- * ServeConnection

20− , ServeConnection

21− , serveDefault

22− , serveHTTP2

23 -- * Connection

12 -- * Connection

24 , Connection (..)

13 , Connection (..)

25 , socketConnection

14 , socketConnection

warp/Network/Wai/Handler/Warp/RequestHeader.hs+1−2

@@ -3,7 +3,6 @@

4module Network.Wai.Handler.Warp.RequestHeader (

5 parseHeaderLines

6− , parseByteRanges

7 ) where

6 ) where

9import Control.Exception (throwIO)

8import Control.Exception (throwIO)

@@ -18,7 +17,7 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

18import Foreign.Storable (peek)

17import Foreign.Storable (peek)

19import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

20import Network.Wai.Handler.Warp.Types

19import Network.Wai.Handler.Warp.Types

21−import Network.Wai.Internal (parseByteRanges)

20+

22-- $setup

21-- $setup

23-- >>> :set -XOverloadedStrings

22-- >>> :set -XOverloadedStrings

warp/Network/Wai/Handler/Warp/Run.hs+28−104

@@ -25,7 +25,6 @@ import Network (sClose, Socket)

25import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))

26import qualified Network.Socket.ByteString as Sock

27import Network.Wai

28−import Network.Wai.HTTP2 (HTTP2Application, promoteApplication)

29import Network.Wai.Handler.Warp.Buffer

28import Network.Wai.Handler.Warp.Buffer

30import Network.Wai.Handler.Warp.Counter

29import Network.Wai.Handler.Warp.Counter

31import qualified Network.Wai.Handler.Warp.Date as D

30import qualified Network.Wai.Handler.Warp.Date as D

@@ -74,23 +73,10 @@ allowInterrupt :: IO ()

74allowInterrupt = unblock $ return ()

73allowInterrupt = unblock $ return ()

75#endif

74#endif

77−-- Composition over two arguments at once; used for runHTTP2\*.

78−(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

79−f .: g = curry $ f . uncurry g

80−

81-- | Run an 'Application' on the given port.

76-- | Run an 'Application' on the given port.

82-- This calls 'runSettings' with 'defaultSettings'.

77-- This calls 'runSettings' with 'defaultSettings'.

83run :: Port -> Application -> IO ()

78run :: Port -> Application -> IO ()

84−run port = runServe port . serveDefault

85−

86−-- | Serve an 'HTTP2Application' and an 'Application' together on the given

87−-- port.

88−runHTTP2 :: Port -> HTTP2Application -> Application -> IO ()

89−runHTTP2 port = runServe port .: serveHTTP2

90−

91−-- | The generalized form of 'run'.

92−runServe :: Port -> ServeConnection -> IO ()

93−runServe p = runServeSettings defaultSettings { settingsPort = p }

79+run p = runSettings defaultSettings { settingsPort = p }

95-- | Run an 'Application' on the port present in the @PORT@

81-- | Run an 'Application' on the port present in the @PORT@

96-- environment variable. Uses the 'Port' given when the variable is unset.

82-- environment variable. Uses the 'Port' given when the variable is unset.

@@ -98,44 +84,28 @@ runServe p = runServeSettings defaultSettings { settingsPort = p }

98--

84--

99-- Since 3.0.9

85-- Since 3.0.9

100runEnv :: Port -> Application -> IO ()

86runEnv :: Port -> Application -> IO ()

101−runEnv port = runServeEnv port . serveDefault

87+runEnv p app = do

102−

103−-- | The HTTP\/2-aware form of 'runEnv'.

104−runHTTP2Env :: Port -> HTTP2Application -> Application -> IO ()

105−runHTTP2Env port = runServeEnv port .: serveHTTP2

106−

107−-- | The generalized form of 'runEnv'.

108−runServeEnv :: Port -> ServeConnection -> IO ()

109−runServeEnv p serveConn = do

110 mp <- lookup "PORT" <$> getEnvironment

88 mp <- lookup "PORT" <$> getEnvironment

111

112− maybe (runServe p serveConn) runReadPort mp

90+ maybe (run p app) runReadPort mp

113

114 where

92 where

115 runReadPort :: String -> IO ()

93 runReadPort :: String -> IO ()

116 runReadPort sp = case reads sp of

94 runReadPort sp = case reads sp of

117− ((p', _):_) -> runServe p' serveConn

95+ ((p', _):_) -> run p' app

118 _ -> fail $ "Invalid value in $PORT: " ++ sp

96 _ -> fail $ "Invalid value in $PORT: " ++ sp

119

120-- | Run an 'Application' with the given 'Settings'.

98-- | Run an 'Application' with the given 'Settings'.

121-- This opens a listen socket on the port defined in 'Settings' and

99-- This opens a listen socket on the port defined in 'Settings' and

122-- calls 'runSettingsSocket'.

100-- calls 'runSettingsSocket'.

123runSettings :: Settings -> Application -> IO ()

101runSettings :: Settings -> Application -> IO ()

124−runSettings set = runServeSettings set . serveDefault

102+runSettings set app = withSocketsDo $

125−

126−-- | The HTTP\/2-aware form of 'runSettings'.

127−runHTTP2Settings :: Settings -> HTTP2Application -> Application -> IO ()

128−runHTTP2Settings set = runServeSettings set .: serveHTTP2

129−

130−-- | The generalized form of 'runSettings'.

131−runServeSettings :: Settings -> ServeConnection -> IO ()

132−runServeSettings set serveConn = withSocketsDo $

133 bracket

103 bracket

134 (bindPortTCP (settingsPort set) (settingsHost set))

104 (bindPortTCP (settingsPort set) (settingsHost set))

135 sClose

105 sClose

136 (\socket -> do

106 (\socket -> do

137 setSocketCloseOnExec socket

107 setSocketCloseOnExec socket

138− runServeSettingsSocket set socket serveConn)

108+ runSettingsSocket set socket app)

139

109

140-- | This installs a shutdown handler for the given socket and

110-- | This installs a shutdown handler for the given socket and

141-- calls 'runSettingsConnection' with the default connection setup action

111-- calls 'runSettingsConnection' with the default connection setup action

@@ -149,22 +119,9 @@ runServeSettings set serveConn = withSocketsDo $

149-- Note that the 'settingsPort' will still be passed to 'Application's via the

119-- Note that the 'settingsPort' will still be passed to 'Application's via the

150-- 'serverPort' record.

120-- 'serverPort' record.

151runSettingsSocket :: Settings -> Socket -> Application -> IO ()

121runSettingsSocket :: Settings -> Socket -> Application -> IO ()

152−runSettingsSocket set socket = runServeSettingsSocket set socket . serveDefault

122+runSettingsSocket set socket app = do

153−

154−-- | The HTTP\/2-aware form of 'runSettingsSocket'.

155−runHTTP2SettingsSocket :: Settings

156− -> Socket

157− -> HTTP2Application

158− -> Application

159− -> IO ()

160−runHTTP2SettingsSocket set socket =

161− runServeSettingsSocket set socket .: serveHTTP2

162−

163−-- | The generalized form of 'runSettingsSocket'.

164−runServeSettingsSocket :: Settings -> Socket -> ServeConnection -> IO ()

165−runServeSettingsSocket set socket serveConn = do

166 settingsInstallShutdownHandler set closeListenSocket

123 settingsInstallShutdownHandler set closeListenSocket

167− runServeSettingsConnection set getConn serveConn

124+ runSettingsConnection set getConn app

168 where

125 where

169 getConn = do

126 getConn = do

170#if WINDOWS

127#if WINDOWS

@@ -188,16 +145,7 @@ runServeSettingsSocket set socket serveConn = do

188--

145--

189-- Since 1.3.5

146-- Since 1.3.5

190runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()

147runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()

191−runSettingsConnection set getConn =

148+runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app

192− runServeSettingsConnection set getConn . serveDefault

193−

194−-- | The generalized form of 'runSettingsConnection'.

195−runServeSettingsConnection :: Settings

196− -> IO (Connection, SockAddr)

197− -> ServeConnection

198− -> IO ()

199−runServeSettingsConnection set getConn serveConn =

200− runServeSettingsConnectionMaker set getConnMaker serveConn

201 where

149 where

202 getConnMaker = do

150 getConnMaker = do

203 (conn, sa) <- getConn

151 (conn, sa) <- getConn

@@ -206,16 +154,8 @@ runServeSettingsConnection set getConn serveConn =

206-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'

154-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'

207-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.

155-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.

208runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

156runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

209−runSettingsConnectionMaker set getConnMaker =

157+runSettingsConnectionMaker x y =

210− runServeSettingsConnectionMaker set getConnMaker . serveDefault

158+ runSettingsConnectionMakerSecure x (toTCP <$> y)

211−

212−-- | The generalized form of 'runSettingsConnectionMaker'.

213−runServeSettingsConnectionMaker :: Settings

214− -> IO (IO Connection, SockAddr)

215− -> ServeConnection

216− -> IO ()

217−runServeSettingsConnectionMaker x y =

218− runServeSettingsConnectionMakerSecure x (toTCP <$> y)

219 where

159 where

220 toTCP = first ((, TCP) <$>)

160 toTCP = first ((, TCP) <$>)

221

161

@@ -228,18 +168,10 @@ runServeSettingsConnectionMaker x y =

228--

168--

229-- Since 2.1.4

169-- Since 2.1.4

230runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()

170runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()

231−runSettingsConnectionMakerSecure set getConnMaker =

171+runSettingsConnectionMakerSecure set getConnMaker app = do

232− runServeSettingsConnectionMakerSecure set getConnMaker . serveDefault

233−

234−-- | The generalized form of 'runSettingsConnectionMakerSecure'.

235−runServeSettingsConnectionMakerSecure :: Settings

236− -> IO (IO (Connection, Transport), SockAddr)

237− -> ServeConnection

238− -> IO ()

239−runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do

240 settingsBeforeMainLoop set

172 settingsBeforeMainLoop set

241 counter <- newCounter

173 counter <- newCounter

242− withII $ acceptConnection set getConnMaker serveConn counter

174+ withII $ acceptConnection set getConnMaker app counter

243 where

175 where

244 withII action =

176 withII action =

245 D.withDateCache $ \dc ->

177 D.withDateCache $ \dc ->

@@ -273,11 +205,11 @@ runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do

273-- Our approach is explained in the comments below.

205-- Our approach is explained in the comments below.

274acceptConnection :: Settings

206acceptConnection :: Settings

275 -> IO (IO (Connection, Transport), SockAddr)

207 -> IO (IO (Connection, Transport), SockAddr)

276− -> ServeConnection

208+ -> Application

277 -> Counter

209 -> Counter

278 -> InternalInfo

210 -> InternalInfo

279 -> IO ()

211 -> IO ()

280−acceptConnection set getConnMaker serveConn counter ii0 = do

212+acceptConnection set getConnMaker app counter ii0 = do

281 -- First mask all exceptions in acceptLoop. This is necessary to

213 -- First mask all exceptions in acceptLoop. This is necessary to

282 -- ensure that no async exception is throw between the call to

214 -- ensure that no async exception is throw between the call to

283 -- acceptNewConnection and the registering of connClose.

215 -- acceptNewConnection and the registering of connClose.

@@ -299,7 +231,7 @@ acceptConnection set getConnMaker serveConn counter ii0 = do

299 case mx of

231 case mx of

300 Nothing -> return ()

232 Nothing -> return ()

301 Just (mkConn, addr) -> do

233 Just (mkConn, addr) -> do

302− fork set mkConn addr serveConn counter ii0

234+ fork set mkConn addr app counter ii0

303 acceptLoop

235 acceptLoop

304

236

305 acceptNewConnection = do

237 acceptNewConnection = do

@@ -323,11 +255,11 @@ acceptConnection set getConnMaker serveConn counter ii0 = do

323fork :: Settings

255fork :: Settings

324 -> IO (Connection, Transport)

256 -> IO (Connection, Transport)

325 -> SockAddr

257 -> SockAddr

326− -> ServeConnection

258+ -> Application

327 -> Counter

259 -> Counter

328 -> InternalInfo

260 -> InternalInfo

329 -> IO ()

261 -> IO ()

330−fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ unmask ->

262+fork set mkConn addr app counter ii0 = settingsFork set $ \ unmask ->

331 -- Run the connection maker to get a new connection, and ensure

263 -- Run the connection maker to get a new connection, and ensure

332 -- that the connection is closed. If the mkConn call throws an

264 -- that the connection is closed. If the mkConn call throws an

333 -- exception, we will leak the connection. If the mkConn call is

265 -- exception, we will leak the connection. If the mkConn call is

@@ -358,29 +290,21 @@ fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ unmask ->

358

290

359 -- Actually serve this connection.

291 -- Actually serve this connection.

360 -- bracket with closeConn above ensures the connection is closed.

292 -- bracket with closeConn above ensures the connection is closed.

361− when goingon $ serveConn conn ii addr transport set

293+ when goingon $ serveConnection conn ii addr transport set app

362 where

294 where

363 closeConn (conn, _transport) = connClose conn

295 closeConn (conn, _transport) = connClose conn

364

296

365 onOpen adr = increase counter >> settingsOnOpen set adr

297 onOpen adr = increase counter >> settingsOnOpen set adr

366 onClose adr _ = decrease counter >> settingsOnClose set adr

298 onClose adr _ = decrease counter >> settingsOnClose set adr

367

299

368−-- The type of a function to serve a fully-prepared connection.

300+serveConnection :: Connection

369−type ServeConnection = Connection

370− -> InternalInfo

301+ -> InternalInfo

371− -> SockAddr

302+ -> SockAddr

372− -> Transport

303+ -> Transport

373− -> Settings

304+ -> Settings

305+ -> Application

374− -> IO ()

306+ -> IO ()

375−

376−-- Serve an HTTP\/2-unaware Application to a connection over any HTTP version.

377−serveDefault :: Application -> ServeConnection

378−serveDefault app = serveHTTP2 (promoteApplication app) app

379−

380−-- Serve an HTTP\/2-aware application over HTTP\/2 or a backup 'Application'

381−-- over HTTP\/1.1 or HTTP\/1.

382−serveHTTP2 :: HTTP2Application -> Application -> ServeConnection

383−serveHTTP2 app2 app conn ii origAddr transport settings = do

307+serveConnection conn ii origAddr transport settings app = do

384 -- fixme: Upgrading to HTTP/2 should be supported.

308 -- fixme: Upgrading to HTTP/2 should be supported.

385 (h2,bs) <- if isHTTP2 transport then

309 (h2,bs) <- if isHTTP2 transport then

386 return (True, "")

310 return (True, "")

@@ -393,7 +317,7 @@ serveHTTP2 app2 app conn ii origAddr transport settings = do

393 if settingsHTTP2Enabled settings && h2 then do

317 if settingsHTTP2Enabled settings && h2 then do

394 recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

318 recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

395 -- fixme: origAddr

319 -- fixme: origAddr

396− http2 conn ii origAddr transport settings recvN app2

320+ http2 conn ii origAddr transport settings recvN app

397 else do

321 else do

398 istatus <- newIORef False

322 istatus <- newIORef False

399 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

323 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))