git.iko.soy/typeable/wai
on master help sign in
warp: withApplication: close socket before exiting
5435169Sönke Hahn
warp/Network/Wai/Handler/Warp/WithApplication.hs+17−12
compare with master
unifiedsplit
@@ -3,6 +3,7 @@ module Network.Wai.Handler.Warp.WithApplication (
3 withApplication,
3 withApplication,
4 testWithApplication,
4 testWithApplication,
5 openFreePort,
5 openFreePort,
6+ withFreePort,
6) where
7) where
7
8
8import Control.Concurrent
9import Control.Concurrent
@@ -16,8 +17,7 @@ import Network.Wai.Handler.Warp.Types
16data App
17data App
17 = App {
18 = App {
18 appThread :: ThreadId,
19 appThread :: ThreadId,
19− appKilled :: Waiter (),
20+ appKilled :: Waiter ()
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
@@ -26,25 +26,26 @@ data App
26withApplication :: IO Application -> (Port -> IO a) -> IO a
26withApplication :: IO Application -> (Port -> IO a) -> IO a
27withApplication mkApp action = do
27withApplication mkApp action = do
28 app <- mkApp
28 app <- mkApp
29− bracket (acquire app) free (\ runningApp -> action (appPort runningApp))
29+ withFreePort $ \ (port, sock) -> do
30+ bracket (start app sock) stop $ \ _ ->
31+ action port
30 where
32 where
31− acquire :: Application -> IO App
33+ start :: Application -> Socket -> IO App
32− acquire app = do
34+ start app sock = do
33− start <- mkWaiter
35+ started <- mkWaiter
34 killed <- mkWaiter
36 killed <- mkWaiter
35 thread <- forkIO $ do
37 thread <- forkIO $ do
36− (port, sock) <- openFreePort
37 let settings =
38 let settings =
38 defaultSettings{
39 defaultSettings{
39− settingsBeforeMainLoop = notify start port
40+ settingsBeforeMainLoop = notify started ()
40 }
41 }
41 runSettingsSocket settings sock app
42 runSettingsSocket settings sock app
42 `finally` notify killed ()
43 `finally` notify killed ()
43− port <- waitFor start
44+ waitFor started
44− return $ App thread killed port
45+ return $ App thread killed
45
46
46− free :: App -> IO ()
47+ stop :: App -> IO ()
47− free runningApp = do
48+ stop runningApp = do
48 killThread $ appThread runningApp
49 killThread $ appThread runningApp
49 waitFor $ appKilled runningApp
50 waitFor $ appKilled runningApp
50
51
@@ -92,3 +93,7 @@ openFreePort = do
92 listen s 1
93 listen s 1
93 port <- socketPort s
94 port <- socketPort s
94 return (fromIntegral port, s)
95 return (fromIntegral port, s)
96+
97+-- | Like 'openFreePort' but closes the socket before exiting.
98+withFreePort :: ((Port, Socket) -> IO a) -> IO a
99+withFreePort = bracket openFreePort (close . snd)
warp/test/WithApplicationSpec.hs+8
@@ -2,8 +2,10 @@
2
2
3module WithApplicationSpec where
3module WithApplicationSpec where
4
4
5+import Control.Concurrent
5import Control.Exception
6import Control.Exception
6import Network.HTTP.Types
7import Network.HTTP.Types
8+import Network.Socket
7import Network.Wai
9import Network.Wai
8import System.IO
10import System.IO
9import System.IO.Silently
11import System.IO.Silently
@@ -35,3 +37,9 @@ spec = do
35 (testWithApplication mkApp $ \ port -> do
37 (testWithApplication mkApp $ \ port -> do
36 readProcess "curl" ["-s", "localhost:" ++ show port] "")
38 readProcess "curl" ["-s", "localhost:" ++ show port] "")
37 `shouldThrow` (errorCall "foo")
39 `shouldThrow` (errorCall "foo")
40+
41+ describe "withFreePort" $ do
42+ it "closes the socket before exiting" $ do
43+ MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do
44+ return sock
45+ readMVar statusMVar `shouldReturn` Closed