@@ -7,6 +7,7 @@ module Network.Wai.Handler.Warp.WithApplication (
77) where
88
99import Control.Concurrent
10+import Control.Concurrent.Async
1011import Control.Exception
1112import Network.Socket
1213import Network.Wai
@@ -14,12 +15,6 @@ import Network.Wai.Handler.Warp.Run
1415import Network.Wai.Handler.Warp.Settings
1516import Network.Wai.Handler.Warp.Types
1617
17−data App
18− = App {
19− appThread :: ThreadId,
20− appKilled :: Waiter ()
21− }
22−
2318-- | Runs the given 'Application' on a free port. Passes the port to the given
2419-- operation and executes it, while the 'Application' is running. Shuts down the
2520-- server before returning.
@@ -27,27 +22,17 @@ withApplication :: IO Application -> (Port -> IO a) -> IO a
2722withApplication mkApp action = do
2823 app <- mkApp
2924 withFreePort $ \ (port, sock) -> do
30− bracket (start app sock) stop $ \ _ ->
31− action port
32− where
33− start :: Application -> Socket -> IO App
34− start app sock = do
35− started <- mkWaiter
36− killed <- mkWaiter
37− thread <- forkIO $ do
38− let settings =
39− defaultSettings{
40− settingsBeforeMainLoop = notify started ()
41− }
42− runSettingsSocket settings sock app
43− `finally` notify killed ()
44− waitFor started
45− return $ App thread killed
46−
47− stop :: App -> IO ()
48− stop runningApp = do
49− killThread $ appThread runningApp
50− waitFor $ appKilled runningApp
25+ started <- mkWaiter
26+ let settings =
27+ defaultSettings{
28+ settingsBeforeMainLoop = notify started ()
29+ }
30+ result <- race
31+ (runSettingsSocket settings sock app)
32+ (waitFor started >> action port)
33+ case result of
34+ Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"
35+ Right x -> return x
5136
5237-- | Same as 'withApplication' but with different exception handling: If the
5338-- given 'Application' throws an exception, 'testWithApplication' will re-throw