@@ -69,18 +69,23 @@ allowInterrupt :: IO ()
69allowInterrupt = unblock $ return ()
69allowInterrupt = unblock $ return ()
72−-- Used to duplicate the 'app' argument for all of the non-HTTP2 variants.
72+-- Composition over two arguments at once; used for runHttp2\*.
73−runWithPromotedApp :: (Http2Application -> Application -> a) -> Application -> a
73+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
74−runWithPromotedApp f = flip f <*> promoteApplication
74+f .: g = curry $ f . uncurry g
76-- | Run an 'Application' on the given port.
76-- | Run an 'Application' on the given port.
77-- This calls 'runSettings' with 'defaultSettings'.
77-- This calls 'runSettings' with 'defaultSettings'.
78run :: Port -> Application -> IO ()
78run :: Port -> Application -> IO ()
79−run = runWithPromotedApp . runHttp2
79+run port = runServe port . serveDefault
81−-- | The HTTP/2-aware eqivalent of 'run'.
81+-- | Serve an 'Http2Application' and an 'Application' together on the given
82runHttp2 :: Port -> Http2Application -> Application -> IO ()
83runHttp2 :: Port -> Http2Application -> Application -> IO ()
84+runHttp2 port = runServe port .: serveHttp2
86+-- | The generalized form of 'run'.
87+runServe :: Port -> ServeConnection -> IO ()
83−runHttp2 p = runHttp2Settings defaultSettings { settingsPort = p }
88+runServe p = runServeSettings defaultSettings { settingsPort = p }
85-- | Run an 'Application' on the port present in the @PORT@
90-- | Run an 'Application' on the port present in the @PORT@
86-- environment variable. Uses the 'Port' given when the variable is unset.
91-- environment variable. Uses the 'Port' given when the variable is unset.
@@ -88,36 +93,44 @@ runHttp2 p = runHttp2Settings defaultSettings { settingsPort = p }
89-- Since 3.0.9
94-- Since 3.0.9
90runEnv :: Port -> Application -> IO ()
95runEnv :: Port -> Application -> IO ()
91−runEnv = runWithPromotedApp . runHttp2Env
96+runEnv port = runServeEnv port . serveDefault
93−-- | The HTTP/2-aware eqivalent of 'runEnv'.
98+-- | The HTTP\/2-aware form of 'runEnv'.
94runHttp2Env :: Port -> Http2Application -> Application -> IO ()
99runHttp2Env :: Port -> Http2Application -> Application -> IO ()
95−runHttp2Env p app2 app = do
100+runHttp2Env port = runServeEnv port .: serveHttp2
102+-- | The generalized form of 'runEnv'.
103+runServeEnv :: Port -> ServeConnection -> IO ()
104+runServeEnv p serveConn = do
96 mp <- fmap (lookup "PORT") getEnvironment
105 mp <- fmap (lookup "PORT") getEnvironment
98− maybe (run p app) runReadPort mp
107+ maybe (runServe p serveConn) runReadPort mp
101 runReadPort :: String -> IO ()
110 runReadPort :: String -> IO ()
102 runReadPort sp = case reads sp of
111 runReadPort sp = case reads sp of
103− ((p', _):_) -> runHttp2 p' app2 app
112+ ((p', _):_) -> runServe p' serveConn
104 _ -> fail $ "Invalid value in $PORT: " ++ sp
113 _ -> fail $ "Invalid value in $PORT: " ++ sp
106-- | Run an 'Application' with the given 'Settings'.
115-- | Run an 'Application' with the given 'Settings'.
107-- This opens a listen socket on the port defined in 'Settings' and
116-- This opens a listen socket on the port defined in 'Settings' and
108-- calls 'runSettingsSocket'.
117-- calls 'runSettingsSocket'.
109runSettings :: Settings -> Application -> IO ()
118runSettings :: Settings -> Application -> IO ()
110−runSettings = runWithPromotedApp . runHttp2Settings
119+runSettings set = runServeSettings set . serveDefault
112−-- | The HTTP/2-aware eqivalent of 'runSettings'.
121+-- | The HTTP\/2-aware form of 'runSettings'.
113runHttp2Settings :: Settings -> Http2Application -> Application -> IO ()
122runHttp2Settings :: Settings -> Http2Application -> Application -> IO ()
114−runHttp2Settings set app2 app = withSocketsDo $
123+runHttp2Settings set = runServeSettings set .: serveHttp2
125+-- | The generalized form of 'runSettings'.
126+runServeSettings :: Settings -> ServeConnection -> IO ()
127+runServeSettings set serveConn = withSocketsDo $
116 (bindPortTCP (settingsPort set) (settingsHost set))
129 (bindPortTCP (settingsPort set) (settingsHost set))
118 (\socket -> do
131 (\socket -> do
119 setSocketCloseOnExec socket
132 setSocketCloseOnExec socket
120− runHttp2SettingsSocket set socket app2 app)
133+ runServeSettingsSocket set socket serveConn)
122-- | This installs a shutdown handler for the given socket and
135-- | This installs a shutdown handler for the given socket and
123-- calls 'runSettingsConnection' with the default connection setup action
136-- calls 'runSettingsConnection' with the default connection setup action
@@ -131,14 +144,22 @@ runHttp2Settings set app2 app = withSocketsDo $
131-- Note that the 'settingsPort' will still be passed to 'Application's via the
144-- Note that the 'settingsPort' will still be passed to 'Application's via the
132-- 'serverPort' record.
145-- 'serverPort' record.
133runSettingsSocket :: Settings -> Socket -> Application -> IO ()
146runSettingsSocket :: Settings -> Socket -> Application -> IO ()
134−runSettingsSocket set socket = runWithPromotedApp $
147+runSettingsSocket set socket = runServeSettingsSocket set socket . serveDefault
135− runHttp2SettingsSocket set socket
148+
137−-- | The HTTP/2-aware eqivalent of 'runSettingsSocket'.
149+-- | The HTTP\/2-aware form of 'runSettingsSocket'.
138−runHttp2SettingsSocket :: Settings -> Socket -> Http2Application -> Application -> IO ()
150+runHttp2SettingsSocket :: Settings
139−runHttp2SettingsSocket set socket app2 app = do
155+runHttp2SettingsSocket set socket =
156+ runServeSettingsSocket set socket .: serveHttp2
158+-- | The generalized form of 'runSettingsSocket'.
159+runServeSettingsSocket :: Settings -> Socket -> ServeConnection -> IO ()
160+runServeSettingsSocket set socket serveConn = do
140 settingsInstallShutdownHandler set closeListenSocket
161 settingsInstallShutdownHandler set closeListenSocket
141− runHttp2SettingsConnection set getConn app2 app
162+ runServeSettingsConnection set getConn serveConn
143 getConn = do
164 getConn = do
144#if WINDOWS
165#if WINDOWS
@@ -162,13 +183,16 @@ runHttp2SettingsSocket set socket app2 app = do
163-- Since 1.3.5
184-- Since 1.3.5
164runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
185runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
165−runSettingsConnection set getConn = runWithPromotedApp $
186+runSettingsConnection set getConn =
166− runHttp2SettingsConnection set getConn
187+ runServeSettingsConnection set getConn . serveDefault
168−-- | The HTTP/2-aware eqivalent of 'runSettingsConnection'.
189+-- | The generalized form of 'runSettingsConnection'.
169−runHttp2SettingsConnection :: Settings -> IO (Connection, SockAddr) -> Http2Application -> Application -> IO ()
190+runServeSettingsConnection :: Settings
170−runHttp2SettingsConnection set getConn app2 app =
191+ -> IO (Connection, SockAddr)
171− runHttp2SettingsConnectionMaker set getConnMaker app2 app
192+ -> ServeConnection
194+runServeSettingsConnection set getConn serveConn =
195+ runServeSettingsConnectionMaker set getConnMaker serveConn
173 getConnMaker = do
197 getConnMaker = do
174 (conn, sa) <- getConn
198 (conn, sa) <- getConn
@@ -177,13 +201,16 @@ runHttp2SettingsConnection set getConn app2 app =
177-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'
201-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'
178-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
202-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
179runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
203runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
180−runSettingsConnectionMaker x y = runWithPromotedApp $
204+runSettingsConnectionMaker set getConnMaker =
181− runHttp2SettingsConnectionMaker x y
205+ runServeSettingsConnectionMaker set getConnMaker . serveDefault
183−-- | The HTTP/2-aware eqivalent of 'runSettingsConnectionMaker'.
207+-- | The generalized form of 'runSettingsConnectionMaker'.
184−runHttp2SettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Http2Application -> Application -> IO ()
208+runServeSettingsConnectionMaker :: Settings
185−runHttp2SettingsConnectionMaker x y =
209+ -> IO (IO Connection, SockAddr)
186− runHttp2SettingsConnectionMakerSecure x (go y)
210+ -> ServeConnection
212+runServeSettingsConnectionMaker x y =
213+ runServeSettingsConnectionMakerSecure x (go y)
188 go = fmap (first (fmap (, TCP)))
215 go = fmap (first (fmap (, TCP)))
@@ -196,19 +223,22 @@ runHttp2SettingsConnectionMaker x y =
197-- Since 2.1.4
224-- Since 2.1.4
198runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
225runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
199−runSettingsConnectionMakerSecure set getConnMaker = runWithPromotedApp $
226+runSettingsConnectionMakerSecure set getConnMaker =
200− runHttp2SettingsConnectionMakerSecure set getConnMaker
227+ runServeSettingsConnectionMakerSecure set getConnMaker . serveDefault
202−-- | The HTTP/2-aware eqivalent of 'runSettingsConnectionMakerSecure'.
229+-- | The generalized form of 'runSettingsConnectionMakerSecure'.
230+runServeSettingsConnectionMakerSecure :: Settings
203−runHttp2SettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Http2Application -> Application -> IO ()
231+ -> IO (IO (Connection, Transport), SockAddr)
204−runHttp2SettingsConnectionMakerSecure set getConnMaker app2 app = do
232+ -> ServeConnection
234+runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do
205 settingsBeforeMainLoop set
235 settingsBeforeMainLoop set
206 counter <- newCounter
236 counter <- newCounter
208 D.withDateCache $ \dc ->
238 D.withDateCache $ \dc ->
209 F.withFdCache fdCacheDurationInSeconds $ \fc ->
239 F.withFdCache fdCacheDurationInSeconds $ \fc ->
210 withTimeoutManager $ \tm ->
240 withTimeoutManager $ \tm ->
211− acceptConnection set getConnMaker app2 app dc fc tm counter
241+ acceptConnection set getConnMaker serveConn dc fc tm counter
213 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
243 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
214 withTimeoutManager f = case settingsManager set of
244 withTimeoutManager f = case settingsManager set of
@@ -233,14 +263,13 @@ runHttp2SettingsConnectionMakerSecure set getConnMaker app2 app = do
233-- Our approach is explained in the comments below.
263-- Our approach is explained in the comments below.
234acceptConnection :: Settings
264acceptConnection :: Settings
235 -> IO (IO (Connection, Transport), SockAddr)
265 -> IO (IO (Connection, Transport), SockAddr)
236− -> Http2Application
266+ -> ServeConnection
238 -> D.DateCache
267 -> D.DateCache
239 -> Maybe F.MutableFdCache
268 -> Maybe F.MutableFdCache
240 -> T.Manager
269 -> T.Manager
241 -> Counter
270 -> Counter
243−acceptConnection set getConnMaker app2 app dc fc tm counter = do
272+acceptConnection set getConnMaker serveConn dc fc tm counter = do
244 -- First mask all exceptions in acceptLoop. This is necessary to
273 -- First mask all exceptions in acceptLoop. This is necessary to
245 -- ensure that no async exception is throw between the call to
274 -- ensure that no async exception is throw between the call to
246 -- acceptNewConnection and the registering of connClose.
275 -- acceptNewConnection and the registering of connClose.
@@ -262,7 +291,7 @@ acceptConnection set getConnMaker app2 app dc fc tm counter = do
262 case mx of
291 case mx of
263 Nothing -> return ()
292 Nothing -> return ()
264 Just (mkConn, addr) -> do
293 Just (mkConn, addr) -> do
265− fork set mkConn addr app2 app dc fc tm counter
294+ fork set mkConn addr serveConn dc fc tm counter
266 acceptLoop
295 acceptLoop
268 acceptNewConnection = do
297 acceptNewConnection = do
@@ -286,14 +315,13 @@ acceptConnection set getConnMaker app2 app dc fc tm counter = do
286fork :: Settings
315fork :: Settings
287 -> IO (Connection, Transport)
316 -> IO (Connection, Transport)
288 -> SockAddr
317 -> SockAddr
289− -> Http2Application
318+ -> ServeConnection
291 -> D.DateCache
319 -> D.DateCache
292 -> Maybe F.MutableFdCache
320 -> Maybe F.MutableFdCache
293 -> T.Manager
321 -> T.Manager
294 -> Counter
322 -> Counter
296−fork set mkConn addr app2 app dc fc tm counter = settingsFork set $ \ unmask ->
324+fork set mkConn addr serveConn dc fc tm counter = settingsFork set $ \ unmask ->
297 -- Run the connection maker to get a new connection, and ensure
325 -- Run the connection maker to get a new connection, and ensure
298 -- that the connection is closed. If the mkConn call throws an
326 -- that the connection is closed. If the mkConn call throws an
299 -- exception, we will leak the connection. If the mkConn call is
327 -- exception, we will leak the connection. If the mkConn call is
@@ -324,22 +352,34 @@ fork set mkConn addr app2 app dc fc tm counter = settingsFork set $ \ unmask ->
325 -- Actually serve this connection.
353 -- Actually serve this connection.
326 -- bracket with closeConn above ensures the connection is closed.
354 -- bracket with closeConn above ensures the connection is closed.
327− when goingon $ serveConnection conn ii addr transport set app2 app
355+ when goingon $ serveConn conn ii addr transport set
329 closeConn (conn, _transport) = connClose conn
357 closeConn (conn, _transport) = connClose conn
331 onOpen adr = increase counter >> settingsOnOpen set adr
359 onOpen adr = increase counter >> settingsOnOpen set adr
332 onClose adr _ = decrease counter >> settingsOnClose set adr
360 onClose adr _ = decrease counter >> settingsOnClose set adr
334−serveConnection :: Connection
362+-- The type of a function to serve a fully-prepared connection.
363+type ServeConnection = Connection
335− -> InternalInfo
364+ -> InternalInfo
336− -> SockAddr
365+ -> SockAddr
337− -> Transport
366+ -> Transport
338− -> Settings
367+ -> Settings
341− -> IO ()
368+ -> IO ()
370+-- Serve an HTTP\/2-aware application, rejecting clients that attempt to use an
371+-- older protocol version.
372+serveHttp2Only :: Http2Application -> ServeConnection
373+serveHttp2Only = error "serveHttp2Only not implemented"
375+-- Serve an HTTP\/2-unaware Application to a connection over any HTTP version.
376+serveDefault :: Application -> ServeConnection
377+serveDefault = flip serveHttp2 <*> promoteApplication
379+-- Serve an HTTP\/2-aware application over HTTP\/2 or a backup 'Application'
380+-- over HTTP\/1.1 or HTTP\/1.
381+serveHttp2 :: Http2Application -> Application -> ServeConnection
342−serveConnection conn ii origAddr transport settings app2 app = do
382+serveHttp2 app2 app conn ii origAddr transport settings = do
343 -- fixme: Upgrading to HTTP/2 should be supported.
383 -- fixme: Upgrading to HTTP/2 should be supported.
344 (h2,bs) <- if isHTTP2 transport then
384 (h2,bs) <- if isHTTP2 transport then
345 return (True, "")
385 return (True, "")