@@ -69,18 +69,23 @@ allowInterrupt :: IO ()
6969allowInterrupt = unblock $ return ()
7070#endif
7171
72−-- Used to duplicate the 'app' argument for all of the non-HTTP2 variants.
73−runWithPromotedApp :: (Http2Application -> Application -> a) -> Application -> a
74−runWithPromotedApp f = flip f <*> promoteApplication
72+-- Composition over two arguments at once; used for runHttp2\*.
73+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
74+f .: g = curry $ f . uncurry g
7575
7676-- | Run an 'Application' on the given port.
7777-- This calls 'runSettings' with 'defaultSettings'.
7878run :: Port -> Application -> IO ()
79−run = runWithPromotedApp . runHttp2
79+run port = runServe port . serveDefault
8080
81−-- | The HTTP/2-aware eqivalent of 'run'.
81+-- | Serve an 'Http2Application' and an 'Application' together on the given
82+-- port.
8283runHttp2 :: Port -> Http2Application -> Application -> IO ()
83−runHttp2 p = runHttp2Settings defaultSettings { settingsPort = p }
84+runHttp2 port = runServe port .: serveHttp2
85+
86+-- | The generalized form of 'run'.
87+runServe :: Port -> ServeConnection -> IO ()
88+runServe p = runServeSettings defaultSettings { settingsPort = p }
8489
8590-- | Run an 'Application' on the port present in the @PORT@
8691-- environment variable. Uses the 'Port' given when the variable is unset.
@@ -88,36 +93,44 @@ runHttp2 p = runHttp2Settings defaultSettings { settingsPort = p }
8893--
8994-- Since 3.0.9
9095runEnv :: Port -> Application -> IO ()
91−runEnv = runWithPromotedApp . runHttp2Env
96+runEnv port = runServeEnv port . serveDefault
9297
93−-- | The HTTP/2-aware eqivalent of 'runEnv'.
98+-- | The HTTP\/2-aware form of 'runEnv'.
9499runHttp2Env :: Port -> Http2Application -> Application -> IO ()
95−runHttp2Env p app2 app = do
100+runHttp2Env port = runServeEnv port .: serveHttp2
101+
102+-- | The generalized form of 'runEnv'.
103+runServeEnv :: Port -> ServeConnection -> IO ()
104+runServeEnv p serveConn = do
96105 mp <- fmap (lookup "PORT") getEnvironment
97106
98− maybe (run p app) runReadPort mp
107+ maybe (runServe p serveConn) runReadPort mp
99108
100109 where
101110 runReadPort :: String -> IO ()
102111 runReadPort sp = case reads sp of
103− ((p', _):_) -> runHttp2 p' app2 app
112+ ((p', _):_) -> runServe p' serveConn
104113 _ -> fail $ "Invalid value in $PORT: " ++ sp
105114
106115-- | Run an 'Application' with the given 'Settings'.
107116-- This opens a listen socket on the port defined in 'Settings' and
108117-- calls 'runSettingsSocket'.
109118runSettings :: Settings -> Application -> IO ()
110−runSettings = runWithPromotedApp . runHttp2Settings
119+runSettings set = runServeSettings set . serveDefault
111120
112−-- | The HTTP/2-aware eqivalent of 'runSettings'.
121+-- | The HTTP\/2-aware form of 'runSettings'.
113122runHttp2Settings :: Settings -> Http2Application -> Application -> IO ()
114−runHttp2Settings set app2 app = withSocketsDo $
123+runHttp2Settings set = runServeSettings set .: serveHttp2
124+
125+-- | The generalized form of 'runSettings'.
126+runServeSettings :: Settings -> ServeConnection -> IO ()
127+runServeSettings set serveConn = withSocketsDo $
115128 bracket
116129 (bindPortTCP (settingsPort set) (settingsHost set))
117130 sClose
118131 (\socket -> do
119132 setSocketCloseOnExec socket
120− runHttp2SettingsSocket set socket app2 app)
133+ runServeSettingsSocket set socket serveConn)
121134
122135-- | This installs a shutdown handler for the given socket and
123136-- calls 'runSettingsConnection' with the default connection setup action
@@ -131,14 +144,22 @@ runHttp2Settings set app2 app = withSocketsDo $
131144-- Note that the 'settingsPort' will still be passed to 'Application's via the
132145-- 'serverPort' record.
133146runSettingsSocket :: Settings -> Socket -> Application -> IO ()
134−runSettingsSocket set socket = runWithPromotedApp $
135− runHttp2SettingsSocket set socket
136−
137−-- | The HTTP/2-aware eqivalent of 'runSettingsSocket'.
138−runHttp2SettingsSocket :: Settings -> Socket -> Http2Application -> Application -> IO ()
139−runHttp2SettingsSocket set socket app2 app = do
147+runSettingsSocket set socket = runServeSettingsSocket set socket . serveDefault
148+
149+-- | The HTTP\/2-aware form of 'runSettingsSocket'.
150+runHttp2SettingsSocket :: Settings
151+ -> Socket
152+ -> Http2Application
153+ -> Application
154+ -> IO ()
155+runHttp2SettingsSocket set socket =
156+ runServeSettingsSocket set socket .: serveHttp2
157+
158+-- | The generalized form of 'runSettingsSocket'.
159+runServeSettingsSocket :: Settings -> Socket -> ServeConnection -> IO ()
160+runServeSettingsSocket set socket serveConn = do
140161 settingsInstallShutdownHandler set closeListenSocket
141− runHttp2SettingsConnection set getConn app2 app
162+ runServeSettingsConnection set getConn serveConn
142163 where
143164 getConn = do
144165#if WINDOWS
@@ -162,13 +183,16 @@ runHttp2SettingsSocket set socket app2 app = do
162183--
163184-- Since 1.3.5
164185runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
165−runSettingsConnection set getConn = runWithPromotedApp $
166− runHttp2SettingsConnection set getConn
167−
168−-- | The HTTP/2-aware eqivalent of 'runSettingsConnection'.
169−runHttp2SettingsConnection :: Settings -> IO (Connection, SockAddr) -> Http2Application -> Application -> IO ()
170−runHttp2SettingsConnection set getConn app2 app =
171− runHttp2SettingsConnectionMaker set getConnMaker app2 app
186+runSettingsConnection set getConn =
187+ runServeSettingsConnection set getConn . serveDefault
188+
189+-- | The generalized form of 'runSettingsConnection'.
190+runServeSettingsConnection :: Settings
191+ -> IO (Connection, SockAddr)
192+ -> ServeConnection
193+ -> IO ()
194+runServeSettingsConnection set getConn serveConn =
195+ runServeSettingsConnectionMaker set getConnMaker serveConn
172196 where
173197 getConnMaker = do
174198 (conn, sa) <- getConn
@@ -177,13 +201,16 @@ runHttp2SettingsConnection set getConn app2 app =
177201-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'
178202-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
179203runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
180−runSettingsConnectionMaker x y = runWithPromotedApp $
181− runHttp2SettingsConnectionMaker x y
182−
183−-- | The HTTP/2-aware eqivalent of 'runSettingsConnectionMaker'.
184−runHttp2SettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Http2Application -> Application -> IO ()
185−runHttp2SettingsConnectionMaker x y =
186− runHttp2SettingsConnectionMakerSecure x (go y)
204+runSettingsConnectionMaker set getConnMaker =
205+ runServeSettingsConnectionMaker set getConnMaker . serveDefault
206+
207+-- | The generalized form of 'runSettingsConnectionMaker'.
208+runServeSettingsConnectionMaker :: Settings
209+ -> IO (IO Connection, SockAddr)
210+ -> ServeConnection
211+ -> IO ()
212+runServeSettingsConnectionMaker x y =
213+ runServeSettingsConnectionMakerSecure x (go y)
187214 where
188215 go = fmap (first (fmap (, TCP)))
189216
@@ -196,19 +223,22 @@ runHttp2SettingsConnectionMaker x y =
196223--
197224-- Since 2.1.4
198225runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
199−runSettingsConnectionMakerSecure set getConnMaker = runWithPromotedApp $
200− runHttp2SettingsConnectionMakerSecure set getConnMaker
201−
202−-- | The HTTP/2-aware eqivalent of 'runSettingsConnectionMakerSecure'.
203−runHttp2SettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Http2Application -> Application -> IO ()
204−runHttp2SettingsConnectionMakerSecure set getConnMaker app2 app = do
226+runSettingsConnectionMakerSecure set getConnMaker =
227+ runServeSettingsConnectionMakerSecure set getConnMaker . serveDefault
228+
229+-- | The generalized form of 'runSettingsConnectionMakerSecure'.
230+runServeSettingsConnectionMakerSecure :: Settings
231+ -> IO (IO (Connection, Transport), SockAddr)
232+ -> ServeConnection
233+ -> IO ()
234+runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do
205235 settingsBeforeMainLoop set
206236 counter <- newCounter
207237
208238 D.withDateCache $ \dc ->
209239 F.withFdCache fdCacheDurationInSeconds $ \fc ->
210240 withTimeoutManager $ \tm ->
211− acceptConnection set getConnMaker app2 app dc fc tm counter
241+ acceptConnection set getConnMaker serveConn dc fc tm counter
212242 where
213243 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
214244 withTimeoutManager f = case settingsManager set of
@@ -233,14 +263,13 @@ runHttp2SettingsConnectionMakerSecure set getConnMaker app2 app = do
233263-- Our approach is explained in the comments below.
234264acceptConnection :: Settings
235265 -> IO (IO (Connection, Transport), SockAddr)
236− -> Http2Application
237− -> Application
266+ -> ServeConnection
238267 -> D.DateCache
239268 -> Maybe F.MutableFdCache
240269 -> T.Manager
241270 -> Counter
242271 -> IO ()
243−acceptConnection set getConnMaker app2 app dc fc tm counter = do
272+acceptConnection set getConnMaker serveConn dc fc tm counter = do
244273 -- First mask all exceptions in acceptLoop. This is necessary to
245274 -- ensure that no async exception is throw between the call to
246275 -- acceptNewConnection and the registering of connClose.
@@ -262,7 +291,7 @@ acceptConnection set getConnMaker app2 app dc fc tm counter = do
262291 case mx of
263292 Nothing -> return ()
264293 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
266295 acceptLoop
267296
268297 acceptNewConnection = do
@@ -286,14 +315,13 @@ acceptConnection set getConnMaker app2 app dc fc tm counter = do
286315fork :: Settings
287316 -> IO (Connection, Transport)
288317 -> SockAddr
289− -> Http2Application
290− -> Application
318+ -> ServeConnection
291319 -> D.DateCache
292320 -> Maybe F.MutableFdCache
293321 -> T.Manager
294322 -> Counter
295323 -> IO ()
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 ->
297325 -- Run the connection maker to get a new connection, and ensure
298326 -- that the connection is closed. If the mkConn call throws an
299327 -- 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 ->
324352
325353 -- Actually serve this connection.
326354 -- 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
328356 where
329357 closeConn (conn, _transport) = connClose conn
330358
331359 onOpen adr = increase counter >> settingsOnOpen set adr
332360 onClose adr _ = decrease counter >> settingsOnClose set adr
333361
334−serveConnection :: Connection
335− -> InternalInfo
336− -> SockAddr
337− -> Transport
338− -> Settings
339− -> Http2Application
340− -> Application
341− -> IO ()
342−serveConnection conn ii origAddr transport settings app2 app = do
362+-- The type of a function to serve a fully-prepared connection.
363+type ServeConnection = Connection
364+ -> InternalInfo
365+ -> SockAddr
366+ -> Transport
367+ -> Settings
368+ -> IO ()
369+
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"
374+
375+-- Serve an HTTP\/2-unaware Application to a connection over any HTTP version.
376+serveDefault :: Application -> ServeConnection
377+serveDefault = flip serveHttp2 <*> promoteApplication
378+
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
382+serveHttp2 app2 app conn ii origAddr transport settings = do
343383 -- fixme: Upgrading to HTTP/2 should be supported.
344384 (h2,bs) <- if isHTTP2 transport then
345385 return (True, "")