@@ -0,0 +1,84 @@
1+
2+module Network.Wai.Handler.Warp.WithApplication (
3+ withApplication,
4+ testWithApplication,
5+ openFreePort,
6+ withFreePort,
7+) where
8+
9+import Control.Concurrent
10+import Control.Concurrent.Async
11+import Control.Exception
12+import Network.Socket
13+import Network.Wai
14+import Network.Wai.Handler.Warp.Run
15+import Network.Wai.Handler.Warp.Settings
16+import Network.Wai.Handler.Warp.Types
17+
18+-- | Runs the given 'Application' on a free port. Passes the port to the given
19+-- operation and executes it, while the 'Application' is running. Shuts down the
20+-- server before returning.
21+withApplication :: IO Application -> (Port -> IO a) -> IO a
22+withApplication mkApp action = do
23+ app <- mkApp
24+ withFreePort $ \ (port, sock) -> do
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
36+
37+-- | Same as 'withApplication' but with different exception handling: If the
38+-- given 'Application' throws an exception, 'testWithApplication' will re-throw
39+-- the exception to the calling thread, possibly interrupting the execution of
40+-- the given operation.
41+--
42+-- This is handy for running tests against an 'Application' over a real network
43+-- port. When running tests, it's useful to let exceptions thrown by your
44+-- 'Application' propagate to the main thread of the test-suite.
45+--
46+-- __The exception handling makes this function unsuitable for use in production.__
47+-- Use 'withApplication' instead.
48+testWithApplication :: IO Application -> (Port -> IO a) -> IO a
49+testWithApplication mkApp action = do
50+ callingThread <- myThreadId
51+ app <- mkApp
52+ let wrappedApp request respond =
53+ app request respond `catch` \ e -> do
54+ throwTo callingThread (e :: SomeException)
55+ throwIO e
56+ withApplication (return wrappedApp) action
57+
58+data Waiter a
59+ = Waiter {
60+ notify :: a -> IO (),
61+ waitFor :: IO a
62+ }
63+
64+mkWaiter :: IO (Waiter a)
65+mkWaiter = do
66+ mvar <- newEmptyMVar
67+ return $ Waiter {
68+ notify = putMVar mvar,
69+ waitFor = readMVar mvar
70+ }
71+
72+-- | Opens a socket on a free port and returns both port and socket.
73+openFreePort :: IO (Port, Socket)
74+openFreePort = do
75+ s <- socket AF_INET Stream defaultProtocol
76+ localhost <- inet_addr "127.0.0.1"
77+ bind s (SockAddrInet aNY_PORT localhost)
78+ listen s 1
79+ port <- socketPort s
80+ return (fromIntegral port, s)
81+
82+-- | Like 'openFreePort' but closes the socket before exiting.
83+withFreePort :: ((Port, Socket) -> IO a) -> IO a
84+withFreePort = bracket openFreePort (close . snd)