@@ -1,6 +1,7 @@
11
22module Network.Wai.Handler.Warp.WithApplication (
33 withApplication,
4+ testWithApplication,
45 openFreePort,
56) where
67
@@ -16,15 +17,12 @@ data App
1617 = App {
1718 appThread :: ThreadId,
1819 appKilled :: Waiter (),
19− appExceptionMVar :: MVar (Maybe SomeException),
2020 appPort :: Int
2121 }
2222
2323-- | Runs the given 'Application' on a free port. Passes the port to the given
2424-- operation and executes it, while the 'Application' is running. Shuts down the
2525-- server before returning.
26−--
27−-- Handy for e.g. testing 'Application's over a real network port.
2826withApplication :: IO Application -> (Port -> IO a) -> IO a
2927withApplication mkApp action = do
3028 app <- mkApp
@@ -34,33 +32,42 @@ withApplication mkApp action = do
3432 acquire app = do
3533 start <- mkWaiter
3634 killed <- mkWaiter
37− exceptionMVar_ <- newMVar Nothing
3835 thread <- forkIO $ do
3936 (port, sock) <- openFreePort
4037 let settings =
4138 defaultSettings{
4239 settingsBeforeMainLoop = notify start port
4340 }
44− runSettingsSocket settings sock (handleApp exceptionMVar_ app)
41+ runSettingsSocket settings sock app
4542 `finally` notify killed ()
4643 port <- waitFor start
47− return $ App thread killed exceptionMVar_ port
44+ return $ App thread killed port
4845
4946 free :: App -> IO ()
5047 free runningApp = do
5148 killThread $ appThread runningApp
5249 waitFor $ appKilled runningApp
53− exception <- readMVar (appExceptionMVar runningApp)
54− case exception of
55− Nothing -> return ()
56− Just e -> throwIO e
5750
58−handleApp :: MVar (Maybe SomeException) -> Application -> Application
59−handleApp mvar app request respond = do
60− catch (app request respond) $ \ e -> do
61− modifyMVar_ mvar $ \ _ ->
62− return (Just e)
63− throwIO e
51+-- | Same as 'withApplication' but with different exception handling: If the
52+-- given 'Application' throws an exception, 'testWithApplication' will re-throw
53+-- the exception to the calling thread, possibly interrupting the execution of
54+-- the given operation.
55+--
56+-- This is handy for running tests against an 'Application' over a real network
57+-- port. When running tests, it's useful to let exceptions thrown by your
58+-- 'Application' propagate to the main thread of the test-suite.
59+--
60+-- __The exception handling makes this function unsuitable for use in production.__
61+-- Use 'withApplication' instead.
62+testWithApplication :: IO Application -> (Port -> IO a) -> IO a
63+testWithApplication mkApp action = do
64+ callingThread <- myThreadId
65+ app <- mkApp
66+ let wrappedApp request respond =
67+ app request respond `catch` \ e -> do
68+ throwTo callingThread (e :: SomeException)
69+ throwIO e
70+ withApplication (return wrappedApp) action
6471
6572data Waiter a
6673 = Waiter {