git.iko.soy/typeable/wai
on master help sign in
warp: add testWithApplication
12ab931Sönke Hahn
warp/Network/Wai/Handler/Warp.hs+1
compare with master
unifiedsplit
@@ -91,6 +91,7 @@ module Network.Wai.Handler.Warp (
91 , FileInfo(..)
91 , FileInfo(..)
92 , getFileInfo
92 , getFileInfo
93 , withApplication
93 , withApplication
94+ , testWithApplication
94 , openFreePort
95 , openFreePort
95 -- * Version
96 -- * Version
96 , warpVersion
97 , warpVersion
warp/Network/Wai/Handler/Warp/WithApplication.hs+23−16
@@ -1,6 +1,7 @@
1
1
2module Network.Wai.Handler.Warp.WithApplication (
2module Network.Wai.Handler.Warp.WithApplication (
3 withApplication,
3 withApplication,
4+ testWithApplication,
4 openFreePort,
5 openFreePort,
5) where
6) where
6
7
@@ -16,15 +17,12 @@ data App
16 = App {
17 = App {
17 appThread :: ThreadId,
18 appThread :: ThreadId,
18 appKilled :: Waiter (),
19 appKilled :: Waiter (),
19− appExceptionMVar :: MVar (Maybe SomeException),
20 appPort :: Int
20 appPort :: Int
21 }
21 }
22
22
23-- | Runs the given 'Application' on a free port. Passes the port to the given
23-- | Runs the given 'Application' on a free port. Passes the port to the given
24-- operation and executes it, while the 'Application' is running. Shuts down the
24-- operation and executes it, while the 'Application' is running. Shuts down the
25-- server before returning.
25-- server before returning.
26−--
27−-- Handy for e.g. testing 'Application's over a real network port.
28withApplication :: IO Application -> (Port -> IO a) -> IO a
26withApplication :: IO Application -> (Port -> IO a) -> IO a
29withApplication mkApp action = do
27withApplication mkApp action = do
30 app <- mkApp
28 app <- mkApp
@@ -34,33 +32,42 @@ withApplication mkApp action = do
34 acquire app = do
32 acquire app = do
35 start <- mkWaiter
33 start <- mkWaiter
36 killed <- mkWaiter
34 killed <- mkWaiter
37− exceptionMVar_ <- newMVar Nothing
38 thread <- forkIO $ do
35 thread <- forkIO $ do
39 (port, sock) <- openFreePort
36 (port, sock) <- openFreePort
40 let settings =
37 let settings =
41 defaultSettings{
38 defaultSettings{
42 settingsBeforeMainLoop = notify start port
39 settingsBeforeMainLoop = notify start port
43 }
40 }
44− runSettingsSocket settings sock (handleApp exceptionMVar_ app)
41+ runSettingsSocket settings sock app
45 `finally` notify killed ()
42 `finally` notify killed ()
46 port <- waitFor start
43 port <- waitFor start
47− return $ App thread killed exceptionMVar_ port
44+ return $ App thread killed port
48
45
49 free :: App -> IO ()
46 free :: App -> IO ()
50 free runningApp = do
47 free runningApp = do
51 killThread $ appThread runningApp
48 killThread $ appThread runningApp
52 waitFor $ appKilled runningApp
49 waitFor $ appKilled runningApp
53− exception <- readMVar (appExceptionMVar runningApp)
54− case exception of
55− Nothing -> return ()
56− Just e -> throwIO e
57
50
58−handleApp :: MVar (Maybe SomeException) -> Application -> Application
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
59−handleApp mvar app request respond = do
66+ let wrappedApp request respond =
60− catch (app request respond) $ \ e -> do
67+ app request respond `catch` \ e -> do
61− modifyMVar_ mvar $ \ _ ->
68+ throwTo callingThread (e :: SomeException)
62− return (Just e)
69+ throwIO e
63− throwIO e
70+ withApplication (return wrappedApp) action
64
71
65data Waiter a
72data Waiter a
66 = Waiter {
73 = Waiter {
warp/test/WithApplicationSpec.hs+9−1
@@ -21,9 +21,17 @@ spec = do
21 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
21 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
22 output `shouldBe` "foo"
22 output `shouldBe` "foo"
23
23
24+ it "does not propagate exceptions from the server to the executing thread" $
25+ hSilence [stderr] $ do
26+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
27+ withApplication mkApp $ \ port -> do
28+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
29+ output `shouldContain` "Something went wron"
30+
31+ describe "testWithApplication" $ do
24 it "propagates exceptions from the server to the executing thread" $
32 it "propagates exceptions from the server to the executing thread" $
25 hSilence [stderr] $ do
33 hSilence [stderr] $ do
26 let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
34 let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
27− (withApplication mkApp $ \ port -> do
35+ (testWithApplication mkApp $ \ port -> do
28 readProcess "curl" ["-s", "localhost:" ++ show port] "")
36 readProcess "curl" ["-s", "localhost:" ++ show port] "")
29 `shouldThrow` (errorCall "foo")
37 `shouldThrow` (errorCall "foo")