@@ -0,0 +1,87 @@
1+
2+module Network.Wai.Handler.Warp.WithApplication (
3+ withApplication,
4+ openFreePort,
5+) where
6+
7+import Control.Concurrent
8+import Control.Exception
9+import Network.Socket
10+import Network.Wai
11+import Network.Wai.Handler.Warp.Run
12+import Network.Wai.Handler.Warp.Settings
13+import Network.Wai.Handler.Warp.Types
14+
15+data App
16+ = App {
17+ appThread :: ThreadId,
18+ appKilled :: Waiter (),
19+ appExceptionMVar :: MVar (Maybe SomeException),
20+ appPort :: Int
21+ }
22+
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
25+-- server before returning.
26+--
27+-- Handy for e.g. testing 'Application's over a real network port.
28+withApplication :: IO Application -> (Port -> IO a) -> IO a
29+withApplication mkApp action = do
30+ app <- mkApp
31+ bracket (acquire app) free (\ runningApp -> action (appPort runningApp))
32+ where
33+ acquire :: Application -> IO App
34+ acquire app = do
35+ start <- mkWaiter
36+ killed <- mkWaiter
37+ exceptionMVar_ <- newMVar Nothing
38+ thread <- forkIO $ do
39+ (port, sock) <- openFreePort
40+ let settings =
41+ defaultSettings{
42+ settingsBeforeMainLoop = notify start port
43+ }
44+ runSettingsSocket settings sock (handleApp exceptionMVar_ app)
45+ `finally` notify killed ()
46+ port <- waitFor start
47+ return $ App thread killed exceptionMVar_ port
48+
49+ free :: App -> IO ()
50+ free runningApp = do
51+ killThread $ appThread runningApp
52+ waitFor $ appKilled runningApp
53+ exception <- readMVar (appExceptionMVar runningApp)
54+ case exception of
55+ Nothing -> return ()
56+ Just e -> throwIO e
57+
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
64+
65+data Waiter a
66+ = Waiter {
67+ notify :: a -> IO (),
68+ waitFor :: IO a
69+ }
70+
71+mkWaiter :: IO (Waiter a)
72+mkWaiter = do
73+ mvar <- newEmptyMVar
74+ return $ Waiter {
75+ notify = putMVar mvar,
76+ waitFor = readMVar mvar
77+ }
78+
79+-- | Opens a socket on a free port and returns both port and socket.
80+openFreePort :: IO (Port, Socket)
81+openFreePort = do
82+ s <- socket AF_INET Stream defaultProtocol
83+ localhost <- inet_addr "127.0.0.1"
84+ bind s (SockAddrInet aNY_PORT localhost)
85+ listen s 1
86+ port <- socketPort s
87+ return (fromIntegral port, s)