git.iko.soy/typeable/wai
on master help sign in
Getting back to Warp 3.1.3's HTTP/2 code.
commit9faea50b8ff439b3686d30c34bb1e13fe8b63a7c authorKazu Yamamoto <kazu@iij.ad.jp> dateMon 7 Dec 2015, 13:06 (11 years ago) parent565a489
15 files changed+387−1043
compare with master
unifiedsplit
wai/Network/Wai/HTTP2.hs−272 wai/Network/Wai/Internal.hs−97 wai/wai.cabal−2 warp-tls/Network/Wai/Handler/WarpTLS.hs+7−29 warp/Network/Wai/Handler/Warp.hs−9 warp/Network/Wai/Handler/Warp/HTTP2.hs+2−4 warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+13−37 warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+7−8 warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+1−1 warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+239−235 warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+26−78 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+63−154 warp/Network/Wai/Handler/Warp/Internal.hs−11 warp/Network/Wai/Handler/Warp/RequestHeader.hs+1−2 warp/Network/Wai/Handler/Warp/Run.hs+28−104
wai/Network/Wai/HTTP2.hsdeleted−272
@@ -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 @@
11{-# OPTIONS_HADDOCK not-home #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE CPP #-}
4−{-# LANGUAGE OverloadedStrings #-}
54{-# LANGUAGE RankNTypes #-}
65{-# LANGUAGE RecordWildCards #-}
76-- | Internal constructors and helper functions. Note that no guarantees are
@@ -9,25 +8,17 @@
98module Network.Wai.Internal where
109
1110import Blaze.ByteString.Builder (Builder)
12−import Control.Exception (IOException, try)
1311import 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
1712#if __GLASGOW_HASKELL__ < 709
1813import Data.Functor ((<$>))
1914#endif
20−import Data.Maybe (listToMaybe)
2115import Data.Text (Text)
2216import Data.Typeable (Typeable)
2317import Data.Vault.Lazy (Vault)
2418import Data.Word (Word64)
2519import qualified Network.HTTP.Types as H
26−import qualified Network.HTTP.Types.Header as HH
2720import Network.Socket (SockAddr)
28−import Numeric (showInt)
2921import Data.List (intercalate)
30−import qualified System.PosixCompat.Files as P
3122
3223-- | Information on the request sent by the client. This abstracts away the
3324-- details of the underlying implementation.
@@ -157,91 +148,3 @@ data FilePart = FilePart
157148-- Since 3.0.0
158149data ResponseReceived = ResponseReceived
159150 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
2727 , http-types >= 0.7
2828 , text >= 0.7
2929 , transformers >= 0.0
30− , unix-compat >= 0.2
3130 , vault >= 0.3 && < 0.4
3231 Exposed-modules: Network.Wai
33− Network.Wai.HTTP2
3432 Network.Wai.Internal
3533 ghc-options: -Wall
3634
warp-tls/Network/Wai/Handler/WarpTLS.hs+7−29
@@ -35,8 +35,6 @@ module Network.Wai.Handler.WarpTLS (
3535 -- * Runner
3636 , runTLS
3737 , runTLSSocket
38− , runHTTP2TLS
39− , runHTTP2TLSSocket
4038 -- * Exception
4139 , WarpTLSException (..)
4240 ) where
@@ -60,7 +58,6 @@ import Network.Socket.ByteString (sendAll)
6058import qualified Network.TLS as TLS
6159import qualified Network.TLS.Extra as TLSExtra
6260import Network.Wai (Application)
63−import Network.Wai.HTTP2 (HTTP2Application)
6461import Network.Wai.Handler.Warp
6562import Network.Wai.Handler.Warp.Internal
6663import System.IO.Error (isEOFError)
@@ -221,39 +218,20 @@ tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings
221218
222219----------------------------------------------------------------
223220
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−
228221-- | Running 'Application' with 'TLSSettings' and 'Settings'.
229222runTLS :: 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 $
238224 bracket
239225 (bindPortTCP (getPort set) (getHost set))
240226 sClose
241− (\sock -> runServeTLSSocket tset set sock serve)
227+ (\sock -> runTLSSocket tset set sock app)
242228
243229----------------------------------------------------------------
244230
245231-- | Running 'Application' with 'TLSSettings' and 'Settings' using
246232-- specified 'Socket'.
247233runTLSSocket :: 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
257235 credential <- case (certMemory, keyMemory) of
258236 (Nothing, Nothing) ->
259237 either error id <$>
@@ -263,11 +241,11 @@ runServeTLSSocket tlsset@TLSSettings{..} set sock serve = do
263241 key <- maybe (S.readFile keyFile) return mkey
264242 either error return $
265243 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key
266− runServeTLSSocket' tlsset set credential sock serve
244+ runTLSSocket' tlsset set credential sock app
267245
268−runServeTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> ServeConnection -> IO ()
269−runServeTLSSocket' tlsset@TLSSettings{..} set credential sock serve =
270− runServeSettingsConnectionMakerSecure set get serve
246+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()
247+runTLSSocket' tlsset@TLSSettings{..} set credential sock app =
248+ runSettingsConnectionMakerSecure set get app
271249 where
272250 get = getter tlsset sock params
273251 params = TLS.ServerParams {
warp/Network/Wai/Handler/Warp.hs−9
@@ -44,15 +44,6 @@ module Network.Wai.Handler.Warp (
4444 , runEnv
4545 , runSettings
4646 , 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
5647 -- * Settings
5748 , Settings
5849 , defaultSettings
warp/Network/Wai/Handler/Warp/HTTP2.hs+2−4
@@ -7,11 +7,9 @@ import Control.Concurrent (forkIO, killThread)
77import qualified Control.Exception as E
88import Control.Monad (when, unless, replicateM_)
99import Data.ByteString (ByteString)
10−
1110import Network.HTTP2
1211import Network.Socket (SockAddr)
13−
14−import Network.Wai.HTTP2 (HTTP2Application)
12+import Network.Wai
1513import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
1614import Network.Wai.Handler.Warp.HTTP2.Manager
1715import Network.Wai.Handler.Warp.HTTP2.Receiver
@@ -24,7 +22,7 @@ import Network.Wai.Handler.Warp.Types
2422
2523----------------------------------------------------------------
2624
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 ()
2826http2 conn ii addr transport settings readN app = do
2927 checkTLS
3028 ok <- checkPreface
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+13−37
@@ -5,7 +5,6 @@ module Network.Wai.Handler.Warp.HTTP2.HPACK where
55
66import Control.Arrow (first)
77import qualified Control.Exception as E
8−import qualified Data.ByteString as B
98import Data.ByteString.Builder (Builder)
109import qualified Data.ByteString.Char8 as B8
1110import Data.CaseInsensitive (foldedCase)
@@ -13,39 +12,30 @@ import Data.IORef (readIORef, writeIORef)
1312import Network.HPACK
1413import qualified Network.HTTP.Types as H
1514import Network.HTTP2
15+import Network.Wai
1616import Network.Wai.Handler.Warp.HTTP2.Types
1717import Network.Wai.Handler.Warp.Header
1818import Network.Wai.Handler.Warp.Response
1919import qualified Network.Wai.Handler.Warp.Settings as S
2020import Network.Wai.Handler.Warp.Types
2121
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
28− -> H.ResponseHeaders -> IO Builder
29−hpackEncodeHeader ctx ii settings s h = do
30− hdr1 <- addServerAndDate h
22+hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response
23+ -> IO Builder
24+hpackEncodeHeader Context{encodeDynamicTable} ii settings rsp = do
25+ hdr1 <- addServerAndDate hdr0
3126 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
3331 where
34− status = B8.pack $ show $ H.statusCode $ s
32+ hdr0 = responseHeaders rsp
33+ status = B8.pack $ show $ H.statusCode $ responseStatus rsp
3534 dc = dateCacher ii
36− rspidxhdr = indexResponseHeader h
35+ rspidxhdr = indexResponseHeader hdr0
3736 defServer = S.settingsServerName settings
3837 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
3938
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
4939
5040----------------------------------------------------------------
5141
@@ -54,20 +44,6 @@ hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do
5444 hdrtbl <- readIORef decodeDynamicTable
5545 (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
5646 writeIORef decodeDynamicTable hdrtbl'
57− return $ concatCookie hdr
47+ return hdr
5848 where
5949 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
5656 cont <- processStreamGuardingError $ decodeFrameHeader hd
5757 when cont loop
5858
59− processStreamGuardingError (FrameHeaders, FrameHeader{streamId})
59+ processStreamGuardingError (_, FrameHeader{streamId})
6060 | isResponse streamId = E.throwIO $ ConnectionError ProtocolError "stream id should be odd"
6161 processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do
6262 mx <- readIORef continued
@@ -161,15 +161,15 @@ frameReceiver ctx mkreq recvN = loop `E.catch` sendGoaway
161161 -- idle, so that receiving frames on it is only a
162162 -- stream error.
163163 consume payloadLength
164− strm <- newStream concurrency streamId 0
164+ strm <- newStream streamId 0
165165 writeIORef (streamState strm) $ Closed $
166166 ResetByMe $ E.toException $
167167 StreamError RefusedStream streamId
168168 insert streamTable streamId strm
169169 E.throwIO $ StreamError RefusedStream streamId
170170 ws <- initialWindowSize <$> readIORef http2settings
171− newstrm <- newStream concurrency streamId (fromIntegral ws)
172− when (ftyp == FrameHeaders) $ opened newstrm
171+ newstrm <- newStream streamId (fromIntegral ws)
172+ when (ftyp == FrameHeaders) $ opened ctx newstrm
173173 insert streamTable streamId newstrm
174174 return newstrm
175175
@@ -186,7 +186,7 @@ control FrameSettings header@FrameHeader{flags} bs Context{http2settings, output
186186 unless (testAck flags) $ do
187187 modifyIORef http2settings $ \old -> updateSettings old alist
188188 let frame = settingsFrame setAck []
189− enqueueControl outputQ 0 $ OSettings frame alist
189+ enqueueControl outputQ 0 $ OFrame frame
190190 return True
191191
192192control FramePing FrameHeader{flags} bs Context{outputQ} =
@@ -311,16 +311,15 @@ stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow
311311 atomically $ writeTVar streamWindow w
312312 return s
313313
314−stream FrameRSTStream header bs _ _ strm = do
314+stream FrameRSTStream header bs ctx _ strm = do
315315 RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs
316316 let cc = Reset e
317− closed strm cc
317+ closed ctx strm cc
318318 return $ Closed cc -- will be written to streamState again
319319
320320stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do
321321 PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs
322322 checkPriority newpri streamNumber
323− -- checkme: this should be tested
324323 oldpre <- readIORef streamPrecedence
325324 let !newpre = toPrecedence newpri
326325 writeIORef streamPrecedence newpre
warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+1−1
@@ -41,7 +41,7 @@ data ValidHeaders = ValidHeaders {
4141 vhMethod :: ByteString
4242 , vhPath :: ByteString
4343 , vhAuth :: Maybe ByteString
44− , vhCL :: Maybe Int -- ^ Content-Length
44+ , vhCL :: Maybe Int
4545 , vhHeader :: RequestHeaders
4646 }
4747
warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+239−235
@@ -7,71 +7,55 @@ module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where
77#if __GLASGOW_HASKELL__ < 709
88import Control.Applicative
99#endif
10−import Control.Concurrent.MVar (putMVar)
1110import Control.Concurrent.STM
1211import qualified Control.Exception as E
13−import Control.Monad (void, when)
12+import Control.Monad (unless, void, when)
1413import qualified Data.ByteString as BS
15−import qualified Data.ByteString.Builder as B (int32BE)
1614import qualified Data.ByteString.Builder.Extra as B
17−import Data.Monoid ((<>))
1815import Foreign.Ptr
19−import qualified Network.HTTP.Types as H
20−import Network.HPACK (setLimitForEncoding)
2116import Network.HTTP2
2217import Network.HTTP2.Priority
23−import Network.Wai (FilePart(..))
24−import Network.Wai.HTTP2 (Trailers, promiseHeaders)
18+import Network.Wai
2519import Network.Wai.Handler.Warp.Buffer
2620import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
2721import Network.Wai.Handler.Warp.HTTP2.HPACK
2822import Network.Wai.Handler.Warp.HTTP2.Types
2923import Network.Wai.Handler.Warp.IORef
3024import qualified Network.Wai.Handler.Warp.Settings as S
25+import qualified Network.Wai.Handler.Warp.Timeout as T
3126import Network.Wai.Handler.Warp.Types
27+import Network.Wai.Internal (Response(..))
28+import qualified System.PosixCompat.Files as P
3229
3330#ifdef WINDOWS
3431import qualified System.IO as IO
3532#else
36−import Network.Wai.Handler.Warp.FdCache (getFd)
33+import Network.Wai.Handler.Warp.FdCache
3734import Network.Wai.Handler.Warp.SendFile (positionRead)
38−import qualified Network.Wai.Handler.Warp.Timeout as T
3935import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
40−import System.Posix.Types (Fd)
36+import System.Posix.Types
4137#endif
4238
4339----------------------------------------------------------------
4440
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−
5441data Leftover = LZero
5542 | LOne B.BufferWriter
5643 | LTwo BS.ByteString B.BufferWriter
57− | LFile OpenFile Integer Integer (IO ())
5844
5945----------------------------------------------------------------
6046
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
64−unlessClosed Connection{connSendAll}
47+unlessClosed :: Context -> Connection -> Stream -> IO () -> IO ()
48+unlessClosed ctx
49+ Connection{connSendAll}
6550 strm@Stream{streamState,streamNumber}
6651 body = E.handle resetStream $ do
6752 state <- readIORef streamState
68− if (isClosed state) then return False else body >> return True
53+ unless (isClosed state) body
6954 where
7055 resetStream e = do
71− closed strm (ResetByMe e)
56+ closed ctx strm (ResetByMe e)
7257 let rst = resetFrame InternalError streamNumber
7358 connSendAll rst
74− return False
7559
7660getWindowSize :: TVar WindowSize -> TVar WindowSize -> IO WindowSize
7761getWindowSize connWindow strmWindow = do
@@ -85,7 +69,7 @@ getWindowSize connWindow strmWindow = do
8569 return $ min cw sw
8670
8771frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO ()
88−frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
72+frameSender ctx@Context{outputQ,connectionWindow}
8973 conn@Connection{connWriteBuffer,connBufferSize,connSendAll}
9074 ii settings = go `E.catch` ignore
9175 where
@@ -106,112 +90,69 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
10690
10791 switch OFinish _ = return ()
10892 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
11793 switch (OFrame frame) _ = do
11894 connSendAll frame
11995 loop
120− switch (OResponse strm s h aux) pre = do
121− writeIORef (streamPrecedence strm) pre -- fixme
122− _ <- unlessClosed conn strm $
123− getWindowSize connectionWindow (streamWindow strm) >>=
124− sendResponse strm s h aux
96+ switch (OResponse strm rsp aux) pre = do
97+ writeIORef (streamPrecedence strm) pre
98+ unlessClosed ctx conn strm $ do
99+ lim <- getWindowSize connectionWindow (streamWindow strm)
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
125134 loop
126135 switch (ONext strm curr) pre = do
127136 writeIORef (streamPrecedence strm) pre
128− _ <- unlessClosed conn strm $ do
137+ unlessClosed ctx conn strm $ do
129138 lim <- getWindowSize connectionWindow (streamWindow strm)
130139 -- Data frame payload
131140 Next datPayloadLen mnext <- curr lim
132− fillDataHeaderSend strm 0 datPayloadLen
133− dispatchNext 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
141+ fillDataHeaderSend strm 0 datPayloadLen mnext
142+ maybeEnqueueNext strm mnext
147143 loop
148144
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−
192145 -- Flush the connection buffer to the socket, where the first 'n' bytes of
193146 -- the buffer are filled.
194147 flushN :: Int -> IO ()
195148 flushN n = bufferIO connWriteBuffer n connSendAll
196149
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
213152 (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
215156 flag = if endOfStream then setEndStream flag0 else flag0
216157 fillFrameHeader FrameHeaders len sid flag connWriteBuffer
217158 continue sid len signal
@@ -220,7 +161,9 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
220161 continue sid len (B.More _ writer) = do
221162 flushN $ len + frameHeaderLength
222163 (len', signal') <- writer bufHeaderPayload headerPayloadLim
223− let flag = maybeEndHeaders signal'
164+ let flag = case signal' of
165+ B.Done -> setEndHeader defaultFlags
166+ _ -> defaultFlags
224167 fillFrameHeader FrameContinuation len' sid flag connWriteBuffer
225168 continue sid len' signal'
226169 continue sid len (B.Chunk bs writer) = do
@@ -237,22 +180,16 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
237180 -- True if the connection buffer has room for a 1-byte data frame.
238181 canFitDataFrame total = total + frameHeaderLength < connBufferSize
239182
240− -- Take the appropriate action based on the given 'Control':
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.
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 ()
251− dispatchNext _ CNone = return ()
252− dispatchNext strm (CFinish trailers) = sendTrailers strm trailers
253− dispatchNext strm (CNext next) = do
183+ -- Re-enqueue the stream in the output queue if more output is immediately
184+ -- available; do nothing otherwise.
185+ maybeEnqueueNext :: Stream -> Control DynaNext -> IO ()
186+ maybeEnqueueNext strm (CNext next) = do
254187 let out = ONext strm next
255188 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 ()
256193
257194
258195 -- 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}
264201 flushN total
265202 return (0, False)
266203
267− fillDataHeaderSend strm otherLen datPayloadLen = do
204+ fillDataHeaderSend strm otherLen datPayloadLen mnext = do
268205 -- Data frame header
269206 let sid = streamNumber strm
270207 buf = connWriteBuffer `plusPtr` otherLen
271208 total = otherLen + frameHeaderLength + datPayloadLen
272− fillFrameHeader FrameData datPayloadLen sid defaultFlags buf
209+ flag = case mnext of
210+ CFinish -> setEndStream defaultFlags
211+ _ -> defaultFlags
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 ()
273219 flushN total
274220 atomically $ do
275221 modifyTVar' connectionWindow (subtract datPayloadLen)
@@ -281,108 +227,130 @@ frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}
281227
282228----------------------------------------------------------------
283229
284−fillStreamBodyGetNext :: InternalInfo -> Connection -> Int -> WindowSize
285− -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next
286−fillStreamBodyGetNext ii Connection{connWriteBuffer,connBufferSize}
287− off lim sq tvar strm = do
230+{-
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
238+fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}
239+ _ off lim (ResponseBuilder _ _ bb) = do
288240 let datBuf = connWriteBuffer `plusPtr` off
289241 room = min (connBufferSize - off) lim
290− (leftover, cont, len) <- runStreamBuilder ii datBuf room sq
291− nextForStream ii connWriteBuffer connBufferSize sq tvar strm leftover cont len
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
242+ (len, signal) <- B.runBuilder bb datBuf room
243+ return $ nextForBuilder connWriteBuffer connBufferSize len signal
329244
330245#ifdef WINDOWS
331−runStreamFile _ buf room path part = do
332− let start = filePartOffset part
333− bytes = filePartByteCount part
246+fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}
247+ _ off lim (ResponseFile _ _ path mpart) = do
248+ let datBuf = connWriteBuffer `plusPtr` off
249+ room = min (connBufferSize - off) lim
250+ (start, bytes) <- fileStartEnd path mpart
334251 -- fixme: how to close Handle? GC does it at this moment.
335252 h <- IO.openBinaryFile path IO.ReadMode
336253 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 ())
340257#else
341−runStreamFile ii buf room path part = do
342− let start = filePartOffset part
343− bytes = filePartByteCount part
258+fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}
259+ ii off lim (ResponseFile _ _ path mpart) = do
344260 (fd, refresh) <- case fdCacher ii of
345261 Just fdcache -> getFd fdcache path
346262 Nothing -> do
347263 fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
348264 th <- T.register (timeoutManager ii) (closeFd fd')
349265 return (fd', T.tickle th)
350− fillBufFile buf room fd start bytes refresh
351−
352−readOpenFile = positionRead
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
266+ let datBuf = connWriteBuffer `plusPtr` off
267+ room = min (connBufferSize - off) lim
268+ (start, bytes) <- fileStartEnd path mpart
269+ len <- positionRead fd datBuf (mini room bytes) start
364270 refresh
365271 let len' = fromIntegral len
366− leftover = if bytes > len' then
367− LFile f (start + len') (bytes - len') refresh
368− else
369− LZero
370− return (leftover, len)
272+ return $ nextForFile len connWriteBuffer connBufferSize fd (start + len') (bytes - len') refresh
273+#endif
371274
372−mini :: Int -> Integer -> Int
373−mini i n
374− | fromIntegral i < n = i
375− | otherwise = fromIntegral n
275+fillResponseBodyGetNext _ _ _ _ _ = error "fillResponseBodyGetNext"
276+
277+fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)
278+fileStartEnd path Nothing = do
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
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)
376345
377−fillBufStream :: InternalInfo -> Buffer -> BufSize -> Leftover
378− -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext
379−fillBufStream ii buf0 siz0 leftover0 sq tvar strm lim0 = do
346+fillBufStream :: Buffer -> BufSize -> Leftover -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext
347+fillBufStream buf0 siz0 leftover0 sq tvar strm lim0 = do
380348 let payloadBuf = buf0 `plusPtr` frameHeaderLength
381349 room0 = min (siz0 - frameHeaderLength) lim0
382350 case leftover0 of
383351 LZero -> do
384− (leftover, end, len) <- runStreamBuilder ii payloadBuf room0 sq
385− getNext leftover end len
352+ (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq
353+ getNext leftover cont len
386354 LOne writer -> write writer payloadBuf room0 0
387355 LTwo bs writer
388356 | BS.length bs <= room0 -> do
@@ -392,35 +360,71 @@ fillBufStream ii buf0 siz0 leftover0 sq tvar strm lim0 = do
392360 | otherwise -> do
393361 let (bs1,bs2) = BS.splitAt room0 bs
394362 void $ copy payloadBuf bs1
395− getNext (LTwo bs2 writer) Nothing room0
396− LFile fd start bytes refresh -> do
397− (leftover, len) <- fillBufFile payloadBuf room0 fd start bytes refresh
398− getNext leftover Nothing len
363+ getNext (LTwo bs2 writer) True room0
399364 where
400− getNext = nextForStream ii buf0 siz0 sq tvar strm
365+ getNext = nextForStream buf0 siz0 sq tvar strm
401366 write writer1 buf room sofar = do
402367 (len, signal) <- writer1 buf room
403368 case signal of
404369 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
406371 let !total = sofar + len + extra
407− getNext leftover end total
372+ getNext leftover cont total
408373 B.More _ writer -> do
409374 let !total = sofar + len
410− getNext (LOne writer) Nothing total
375+ getNext (LOne writer) True total
411376 B.Chunk bs writer -> do
412377 let !total = sofar + len
413− getNext (LTwo bs writer) Nothing total
414−
415−nextForStream :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence
416− -> TVar Sync -> Stream -> Leftover -> Maybe Trailers
417− -> BytesFilled -> IO Next
418−nextForStream _ _ _ _ tvar _ _ (Just trailers) len = do
419− atomically $ writeTVar tvar $ SyncFinish
420− return $ Next len $ CFinish trailers
421−nextForStream ii buf siz sq tvar strm LZero Nothing len = do
422− let out = ONext strm (fillBufStream ii buf siz LZero sq tvar strm)
378+ getNext (LTwo bs writer) True total
379+
380+nextForStream :: Buffer -> BufSize -> TBQueue Sequence -> TVar Sync -> Stream
381+ -> Leftover -> Bool -> BytesFilled
382+ -> IO Next
383+nextForStream _ _ _ tvar _ _ False len = do
384+ atomically $ writeTVar tvar SyncFinish
385+ return $ Next len CFinish
386+nextForStream buf siz sq tvar strm LZero True len = do
387+ let out = ONext strm (fillBufStream buf siz LZero sq tvar strm)
423388 atomically $ writeTVar tvar $ SyncNext out
424389 return $ Next len CNone
425−nextForStream ii buf siz sq tvar strm leftover Nothing len =
426− return $ Next len (CNext (fillBufStream ii buf siz leftover sq tvar strm))
390+nextForStream buf siz sq tvar strm leftover True len =
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
55
66import Data.ByteString.Builder (Builder)
77#if __GLASGOW_HASKELL__ < 709
8−import Control.Applicative ((<$>), (<*>), pure)
8+import Control.Applicative ((<$>),(<*>))
99#endif
1010import Control.Concurrent (forkIO)
11−import Control.Concurrent.MVar (MVar)
1211import Control.Concurrent.STM
1312import Control.Exception (SomeException)
1413import Control.Monad (void)
@@ -18,8 +17,7 @@ import qualified Data.ByteString as BS
1817import Data.IntMap.Strict (IntMap, IntMap)
1918import qualified Data.IntMap.Strict as M
2019import qualified Network.HTTP.Types as H
21−import Network.Wai (Request, FilePart)
22−import Network.Wai.HTTP2 (PushPromise, Trailers)
20+import Network.Wai (Request, Response)
2321import Network.Wai.Handler.Warp.IORef
2422import Network.Wai.Handler.Warp.Types
2523
@@ -38,7 +36,7 @@ isHTTP2 tls = useHTTP2
3836 where
3937 useHTTP2 = case tlsNegotiatedProtocol tls of
4038 Nothing -> False
41− Just proto -> "h2-" `BS.isPrefixOf` proto || proto == "h2"
39+ Just proto -> "h2-" `BS.isPrefixOf` proto
4240
4341----------------------------------------------------------------
4442
@@ -46,21 +44,14 @@ data Input = Input Stream Request
4644
4745----------------------------------------------------------------
4846
49−-- | The result of writing data from a stream's queue into the buffer.
50−data Control a = CFinish Trailers
51− -- ^ The stream has ended, and the trailers should be sent.
47+data Control a = CFinish
5248 | CNext a
53− -- ^ The stream has more data immediately available, and we
54− -- should re-enqueue it when the stream window becomes open.
5549 | 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.
5950
6051instance Show (Control a) where
61− show (CFinish _) = "CFinish"
62− show (CNext _) = "CNext"
63− show CNone = "CNone"
52+ show CFinish = "CFinish"
53+ show (CNext _) = "CNext"
54+ show CNone = "CNone"
6455
6556type DynaNext = WindowSize -> IO Next
6657
@@ -69,54 +60,28 @@ type BytesFilled = Int
6960data Next = Next BytesFilled (Control DynaNext)
7061
7162data Output = OFinish
72− -- ^ Terminate the connection.
7363 | OGoaway ByteString
74− -- ^ Send a goaway frame and terminate the connection.
75− | OSettings ByteString SettingsList
76− -- ^ Update settings and send an ack settings frame.
7764 | OFrame ByteString
78− -- ^ Send an entire pre-encoded frame.
79− | OResponse Stream H.Status H.ResponseHeaders 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.
65+ | OResponse Stream Response Aux
8566 | ONext Stream DynaNext
86− -- ^ Send a chunk of the response.
8767
8868outputStream :: Output -> Stream
89−outputStream (OResponse strm _ _ _) = strm
90−outputStream (ONext strm _) = strm
91−outputStream (OPush strm _ _ _ _ _ _) = strm
92−outputStream _ = error "outputStream"
69+outputStream (OResponse strm _ _) = strm
70+outputStream (ONext strm _) = strm
71+outputStream _ = error "outputStream"
9372
9473----------------------------------------------------------------
9574
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
100− -- ^ The stream is over; its trailers are provided.
75+data Sequence = SFinish
10176 | SFlush
102− -- ^ Any buffered data should be sent immediately.
10377 | 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.
10778
108−-- | A message from the sender to a stream's dedicated waiter thread.
10979data Sync = SyncNone
110− -- ^ Nothing interesting has happened. Go back to sleep.
11180 | SyncFinish
112− -- ^ The stream has ended.
11381 | SyncNext Output
114− -- ^ The stream's queue has been drained; wait for more to be
115− -- available and re-enqueue the given 'Output'.
11682
117−-- | Auxiliary information needed to communicate with a running stream: a queue
118−-- of stream elements ('Sequence') and a 'TVar' connected to its waiter thread.
119−data Aux = Persist (TBQueue Sequence) (TVar Sync)
83+data Aux = Oneshot Bool
84+ | Persist (TBQueue Sequence) (TVar Sync)
12085
12186----------------------------------------------------------------
12287
@@ -124,12 +89,7 @@ data Aux = Persist (TBQueue Sequence) (TVar Sync)
12489data Context = Context {
12590 http2settings :: IORef Settings
12691 , streamTable :: StreamTable
127− -- | Number of active streams initiated by the client; for enforcing our own
128− -- max concurrency setting.
12992 , 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
13393 , priorityTreeSize :: IORef Int
13494 -- | RFC 7540 says "Other frames (from any stream) MUST NOT
13595 -- occur between the HEADERS frame and any CONTINUATION
@@ -137,9 +97,6 @@ data Context = Context {
13797 -- this requirement.
13898 , continued :: IORef (Maybe StreamId)
13999 , currentStreamId :: IORef StreamId
140− -- ^ Last client-initiated stream ID we've handled.
141− , nextPushStreamId :: IORef StreamId
142− -- ^ Next available server-initiated stream ID.
143100 , inputQ :: TQueue Input
144101 , outputQ :: PriorityTree Output
145102 , encodeDynamicTable :: IORef DynamicTable
@@ -154,10 +111,8 @@ newContext = Context <$> newIORef defaultSettings
154111 <*> initialize 10 -- fixme: hard coding: 10
155112 <*> newIORef 0
156113 <*> newIORef 0
157− <*> newIORef 0
158114 <*> newIORef Nothing
159115 <*> newIORef 0
160− <*> newIORef 2 -- first server push stream; 0 is reserved
161116 <*> newTQueueIO
162117 <*> newPriorityTree
163118 <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef)
@@ -224,35 +179,28 @@ data Stream = Stream {
224179 , streamBodyLength :: IORef Int
225180 , streamWindow :: TVar WindowSize
226181 , 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
232182 }
233183
234184instance Show Stream where
235185 show s = show (streamNumber s)
236186
237−newStream :: IORef Int -> StreamId -> WindowSize -> IO Stream
238−newStream ref sid win =
239− Stream sid <$> newIORef Idle
240− <*> newIORef Nothing
241− <*> newIORef 0
242− <*> newTVarIO win
243− <*> newIORef defaultPrecedence
244− <*> pure ref
187+newStream :: StreamId -> WindowSize -> IO Stream
188+newStream sid win = Stream sid <$> newIORef Idle
189+ <*> newIORef Nothing
190+ <*> newIORef 0
191+ <*> newTVarIO win
192+ <*> newIORef defaultPrecedence
245193
246194----------------------------------------------------------------
247195
248−opened :: Stream -> IO ()
249−opened Stream{concurrencyRef,streamState} = do
250− atomicModifyIORef' concurrencyRef (\x -> (x+1,()))
196+opened :: Context -> Stream -> IO ()
197+opened Context{concurrency} Stream{streamState} = do
198+ atomicModifyIORef' concurrency (\x -> (x+1,()))
251199 writeIORef streamState (Open JustOpened)
252200
253−closed :: Stream -> ClosedCode -> IO ()
254−closed Stream{concurrencyRef,streamState} cc = do
255− atomicModifyIORef' concurrencyRef (\x -> (x-1,()))
201+closed :: Context -> Stream -> ClosedCode -> IO ()
202+closed Context{concurrency} Stream{streamState} cc = do
203+ atomicModifyIORef' concurrency (\x -> (x-1,()))
256204 writeIORef streamState (Closed cc)
257205
258206----------------------------------------------------------------
warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+63−154
@@ -1,11 +1,10 @@
11{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE RankNTypes #-}
32{-# LANGUAGE NamedFieldPuns #-}
43{-# LANGUAGE PatternGuards #-}
54{-# LANGUAGE CPP #-}
65
76module Network.Wai.Handler.Warp.HTTP2.Worker (
8− Respond
7+ Responder
98 , response
109 , worker
1110 ) where
@@ -27,153 +26,65 @@ import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
2726import Network.Wai.Handler.Warp.HTTP2.Manager
2827import Network.Wai.Handler.Warp.HTTP2.Types
2928import Network.Wai.Handler.Warp.IORef
30−import Network.Wai.HTTP2
31− ( Chunk(..)
32− , HTTP2Application
33− , PushPromise
34− , Responder(runResponder)
35− , RespondFunc
36− )
29+import qualified Network.Wai.Handler.Warp.Response as R
3730import qualified Network.Wai.Handler.Warp.Settings as S
3831import qualified Network.Wai.Handler.Warp.Timeout as T
32+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))
3933
4034----------------------------------------------------------------
4135
42−-- | An 'HTTP2Application' takes a function of status, headers, trailers, and
43−-- body; this type implements that by currying some internal arguments.
44−--
45−-- The token type of the RespondFunc is set to be (). This is a bit
46−-- anti-climactic, but the real benefit of the token type is that the
47−-- application is forced to call the responder, and making it a boring type
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
54−-- 'HTTP2Application's to this function. This function enqueues commands for
55−-- the HTTP/2 sender.
56−response :: Context -> Manager -> ThreadContinue -> Respond
57−response ctx mgr tconf tickle strm s h strmbdy = do
58− -- TODO(awpr) HEAD requests will still stream.
59−
60− -- We must not exit this WAI application.
61− -- If the application exits, streaming would be also closed.
62− -- So, this work occupies this thread.
63− --
64− -- We need to increase the number of workers.
65− myThreadId >>= replaceWithAction mgr
66− -- After this work, this thread stops to decrease the number of workers.
67− 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.
78− -- So, let's serialize 'Builder' with a designated queue.
79− sq <- newTBQueueIO 10 -- fixme: hard coding: 10
80− tvar <- newTVarIO SyncNone
81− let out = mkOutput strm s h (Persist sq tvar)
82− -- Since we must not enqueue an empty queue to the priority
83− -- queue, we spawn a thread to ensure that the designated
84− -- queue is not empty.
85− void $ forkIO $ waiter tvar sq strm outputQ
86− atomically $ writeTVar tvar $ SyncNext out
87− let write chunk = do
88− atomically $ writeTBQueue sq $ case chunk of
89− BuilderChunk b -> SBuilder b
90− FileChunk path part -> SFile path part
91− tickle
92− flush = atomically $ writeTBQueue sq SFlush
93− trailers <- strmbdy write flush
94− atomically $ writeTBQueue sq $ SFinish trailers
95−
96−-- | Handle abnormal termination of a stream: mark it as closed, send a reset
97−-- frame, and call the user's 'settingsOnException' handler if applicable.
98−cleanupStream :: Context -> S.Settings -> Stream -> Maybe Request -> Maybe SomeException -> IO ()
99−cleanupStream Context{outputQ} set strm req me = do
100− closed strm Killed
101− let sid = streamNumber strm
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
36+-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.
37+-- This type implements the second argument (Response -> IO ResponseReceived)
38+-- with extra arguments.
39+type Responder = ThreadContinue -> T.Handle -> Stream -> Request ->
40+ Response -> IO ResponseReceived
41+
42+-- | This function is passed to workers.
43+-- They also pass 'Response's from 'Application's to this function.
44+-- This function enqueues commands for the HTTP/2 sender.
45+response :: Context -> Manager -> Responder
46+response Context{outputQ} mgr tconf th strm req rsp = do
47+ case rsp of
48+ ResponseStream _ _ strmbdy -> do
49+ -- We must not exit this WAI application.
50+ -- If the application exits, streaming would be also closed.
51+ -- So, this work occupies this thread.
52+ --
53+ -- We need to increase the number of workers.
54+ myThreadId >>= replaceWithAction mgr
55+ -- After this work, this thread stops to decease
56+ -- the number of workers.
57+ setThreadContinue tconf False
58+ -- Since 'StreamingBody' is loop, we cannot control it.
59+ -- So, let's serialize 'Builder' with a designated queue.
60+ sq <- newTBQueueIO 10 -- fixme: hard coding: 10
61+ tvar <- newTVarIO SyncNone
62+ let out = OResponse strm rsp (Persist sq tvar)
63+ -- Since we must not enqueue an empty queue to the priority
64+ -- queue, we spawn a thread to ensure that the designated
65+ -- queue is not empty.
66+ void $ forkIO $ waiter tvar sq outputQ
67+ atomically $ writeTVar tvar (SyncNext out)
68+ let push b = do
69+ atomically $ writeTBQueue sq (SBuilder b)
70+ T.tickle th
71+ flush = atomically $ writeTBQueue sq SFlush
72+ strmbdy push flush
73+ atomically $ writeTBQueue sq SFinish
74+ _ -> do
75+ setThreadContinue tconf True
76+ let hasBody = requestMethod req /= H.methodHead
77+ && R.hasBody (responseStatus rsp)
78+ out = OResponse strm rsp (Oneshot hasBody)
79+ enqueueOrSpawnTemporaryWaiter strm outputQ out
80+ return ResponseReceived
16581
16682data Break = Break deriving (Show, Typeable)
16783
16884instance Exception Break
16985
170−worker :: Context
171− -> S.Settings
172− -> T.Manager
173− -> HTTP2Application
174− -> (ThreadContinue -> Respond)
175− -> IO ()
176−worker ctx@Context{inputQ} set tm app respond = do
86+worker :: Context -> S.Settings -> T.Manager -> Application -> Responder -> IO ()
87+worker ctx@Context{inputQ,outputQ} set tm app responder = do
17788 tid <- myThreadId
17889 sinfo <- newStreamInfo
17990 tcont <- newThreadContinue
@@ -182,17 +93,15 @@ worker ctx@Context{inputQ} set tm app respond = do
18293 where
18394 go sinfo tcont th = do
18495 setThreadContinue tcont True
185−
18696 ex <- E.try $ do
18797 T.pause th
18898 Input strm req <- atomically $ readTQueue inputQ
18999 setStreamInfo sinfo strm req
190100 T.resume th
191101 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
194103 cont1 <- case ex of
195− Right () -> return True
104+ Right ResponseReceived -> return True
196105 Left e@(SomeException _)
197106 | Just Break <- E.fromException e -> do
198107 cleanup sinfo Nothing
@@ -211,16 +120,16 @@ worker ctx@Context{inputQ} set tm app respond = do
211120 case m of
212121 Nothing -> return ()
213122 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
215129 clearStreamInfo sinfo
216130
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 ()
223−waiter tvar sq strm outQ = do
131+waiter :: TVar Sync -> TBQueue Sequence -> PriorityTree Output -> IO ()
132+waiter tvar sq outQ = do
224133 -- waiting for actions other than SyncNone
225134 mx <- atomically $ do
226135 mout <- readTVar tvar
@@ -231,7 +140,7 @@ waiter tvar sq strm outQ = do
231140 return $ Just out
232141 SyncFinish -> return Nothing
233142 case mx of
234− Nothing -> return ()
143+ Nothing -> return ()
235144 Just out -> do
236145 -- ensuring that the streaming queue is not empty.
237146 atomically $ do
@@ -239,14 +148,14 @@ waiter tvar sq strm outQ = do
239148 when isEmpty retry
240149 -- ensuring that stream window is greater than 0.
241150 enqueueWhenWindowIsOpen outQ out
242− waiter tvar sq strm outQ
151+ waiter tvar sq outQ
243152
244153----------------------------------------------------------------
245154
246155-- | It would nice if responders could return values to workers.
247156-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.
248157-- 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.
250159-- The reference refers a value of this type as a return value.
251160-- If 'True', the worker continue to serve requests.
252161-- Otherwise, the worker get finished.
warp/Network/Wai/Handler/Warp/Internal.hs−11
@@ -8,18 +8,7 @@ module Network.Wai.Handler.Warp.Internal (
88 , runSettingsConnection
99 , runSettingsConnectionMaker
1010 , runSettingsConnectionMakerSecure
11− , runServe
12− , runServeEnv
13− , runServeSettings
14− , runServeSettingsSocket
15− , runServeSettingsConnection
16− , runServeSettingsConnectionMaker
17− , runServeSettingsConnectionMakerSecure
1811 , Transport (..)
19− -- * ServeConnection
20− , ServeConnection
21− , serveDefault
22− , serveHTTP2
2312 -- * Connection
2413 , Connection (..)
2514 , socketConnection
warp/Network/Wai/Handler/Warp/RequestHeader.hs+1−2
@@ -3,7 +3,6 @@
33
44module Network.Wai.Handler.Warp.RequestHeader (
55 parseHeaderLines
6− , parseByteRanges
76 ) where
87
98import Control.Exception (throwIO)
@@ -18,7 +17,7 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
1817import Foreign.Storable (peek)
1918import qualified Network.HTTP.Types as H
2019import Network.Wai.Handler.Warp.Types
21−import Network.Wai.Internal (parseByteRanges)
20+
2221-- $setup
2322-- >>> :set -XOverloadedStrings
2423
warp/Network/Wai/Handler/Warp/Run.hs+28−104
@@ -25,7 +25,6 @@ import Network (sClose, Socket)
2525import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))
2626import qualified Network.Socket.ByteString as Sock
2727import Network.Wai
28−import Network.Wai.HTTP2 (HTTP2Application, promoteApplication)
2928import Network.Wai.Handler.Warp.Buffer
3029import Network.Wai.Handler.Warp.Counter
3130import qualified Network.Wai.Handler.Warp.Date as D
@@ -74,23 +73,10 @@ allowInterrupt :: IO ()
7473allowInterrupt = unblock $ return ()
7574#endif
7675
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−
8176-- | Run an 'Application' on the given port.
8277-- This calls 'runSettings' with 'defaultSettings'.
8378run :: 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 }
9480
9581-- | Run an 'Application' on the port present in the @PORT@
9682-- environment variable. Uses the 'Port' given when the variable is unset.
@@ -98,44 +84,28 @@ runServe p = runServeSettings defaultSettings { settingsPort = p }
9884--
9985-- Since 3.0.9
10086runEnv :: Port -> Application -> IO ()
101−runEnv port = runServeEnv port . serveDefault
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
87+runEnv p app = do
11088 mp <- lookup "PORT" <$> getEnvironment
11189
112− maybe (runServe p serveConn) runReadPort mp
90+ maybe (run p app) runReadPort mp
11391
11492 where
11593 runReadPort :: String -> IO ()
11694 runReadPort sp = case reads sp of
117− ((p', _):_) -> runServe p' serveConn
95+ ((p', _):_) -> run p' app
11896 _ -> fail $ "Invalid value in $PORT: " ++ sp
11997
12098-- | Run an 'Application' with the given 'Settings'.
12199-- This opens a listen socket on the port defined in 'Settings' and
122100-- calls 'runSettingsSocket'.
123101runSettings :: Settings -> Application -> IO ()
124−runSettings set = runServeSettings set . serveDefault
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 $
102+runSettings set app = withSocketsDo $
133103 bracket
134104 (bindPortTCP (settingsPort set) (settingsHost set))
135105 sClose
136106 (\socket -> do
137107 setSocketCloseOnExec socket
138− runServeSettingsSocket set socket serveConn)
108+ runSettingsSocket set socket app)
139109
140110-- | This installs a shutdown handler for the given socket and
141111-- calls 'runSettingsConnection' with the default connection setup action
@@ -149,22 +119,9 @@ runServeSettings set serveConn = withSocketsDo $
149119-- Note that the 'settingsPort' will still be passed to 'Application's via the
150120-- 'serverPort' record.
151121runSettingsSocket :: Settings -> Socket -> Application -> IO ()
152−runSettingsSocket set socket = runServeSettingsSocket set socket . serveDefault
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
122+runSettingsSocket set socket app = do
166123 settingsInstallShutdownHandler set closeListenSocket
167− runServeSettingsConnection set getConn serveConn
124+ runSettingsConnection set getConn app
168125 where
169126 getConn = do
170127#if WINDOWS
@@ -188,16 +145,7 @@ runServeSettingsSocket set socket serveConn = do
188145--
189146-- Since 1.3.5
190147runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
191−runSettingsConnection set getConn =
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
148+runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app
201149 where
202150 getConnMaker = do
203151 (conn, sa) <- getConn
@@ -206,16 +154,8 @@ runServeSettingsConnection set getConn serveConn =
206154-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'
207155-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
208156runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
209−runSettingsConnectionMaker set getConnMaker =
210− runServeSettingsConnectionMaker set getConnMaker . serveDefault
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)
157+runSettingsConnectionMaker x y =
158+ runSettingsConnectionMakerSecure x (toTCP <$> y)
219159 where
220160 toTCP = first ((, TCP) <$>)
221161
@@ -228,18 +168,10 @@ runServeSettingsConnectionMaker x y =
228168--
229169-- Since 2.1.4
230170runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
231−runSettingsConnectionMakerSecure set getConnMaker =
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
171+runSettingsConnectionMakerSecure set getConnMaker app = do
240172 settingsBeforeMainLoop set
241173 counter <- newCounter
242− withII $ acceptConnection set getConnMaker serveConn counter
174+ withII $ acceptConnection set getConnMaker app counter
243175 where
244176 withII action =
245177 D.withDateCache $ \dc ->
@@ -273,11 +205,11 @@ runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do
273205-- Our approach is explained in the comments below.
274206acceptConnection :: Settings
275207 -> IO (IO (Connection, Transport), SockAddr)
276− -> ServeConnection
208+ -> Application
277209 -> Counter
278210 -> InternalInfo
279211 -> IO ()
280−acceptConnection set getConnMaker serveConn counter ii0 = do
212+acceptConnection set getConnMaker app counter ii0 = do
281213 -- First mask all exceptions in acceptLoop. This is necessary to
282214 -- ensure that no async exception is throw between the call to
283215 -- acceptNewConnection and the registering of connClose.
@@ -299,7 +231,7 @@ acceptConnection set getConnMaker serveConn counter ii0 = do
299231 case mx of
300232 Nothing -> return ()
301233 Just (mkConn, addr) -> do
302− fork set mkConn addr serveConn counter ii0
234+ fork set mkConn addr app counter ii0
303235 acceptLoop
304236
305237 acceptNewConnection = do
@@ -323,11 +255,11 @@ acceptConnection set getConnMaker serveConn counter ii0 = do
323255fork :: Settings
324256 -> IO (Connection, Transport)
325257 -> SockAddr
326− -> ServeConnection
258+ -> Application
327259 -> Counter
328260 -> InternalInfo
329261 -> IO ()
330−fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ unmask ->
262+fork set mkConn addr app counter ii0 = settingsFork set $ \ unmask ->
331263 -- Run the connection maker to get a new connection, and ensure
332264 -- that the connection is closed. If the mkConn call throws an
333265 -- 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 ->
358290
359291 -- Actually serve this connection.
360292 -- 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
362294 where
363295 closeConn (conn, _transport) = connClose conn
364296
365297 onOpen adr = increase counter >> settingsOnOpen set adr
366298 onClose adr _ = decrease counter >> settingsOnClose set adr
367299
368−-- The type of a function to serve a fully-prepared connection.
369−type ServeConnection = Connection
370− -> InternalInfo
371− -> SockAddr
372− -> Transport
373− -> Settings
374− -> 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
300+serveConnection :: Connection
301+ -> InternalInfo
302+ -> SockAddr
303+ -> Transport
304+ -> Settings
305+ -> Application
306+ -> IO ()
307+serveConnection conn ii origAddr transport settings app = do
384308 -- fixme: Upgrading to HTTP/2 should be supported.
385309 (h2,bs) <- if isHTTP2 transport then
386310 return (True, "")
@@ -393,7 +317,7 @@ serveHTTP2 app2 app conn ii origAddr transport settings = do
393317 if settingsHTTP2Enabled settings && h2 then do
394318 recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
395319 -- fixme: origAddr
396− http2 conn ii origAddr transport settings recvN app2
320+ http2 conn ii origAddr transport settings recvN app
397321 else do
398322 istatus <- newIORef False
399323 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))