Merge pull request #541 from simonmichael/master

don't launch if server fails; kill server on exit #537

wai-handler-launch/Network/Wai/Handler/Launch.hs

@@ -15,7 +15,8 @@ import qualified Network.Wai.Handler.Warp as Warp
 import Data.IORef
 import Data.Monoid (mappend)
 import Data.String (fromString)
-import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.Async (race)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (unless)
 import Control.Exception (throwIO)
@@ -33,9 +34,9 @@ import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)
 import qualified Data.Streaming.Zlib as Z
 
 ping :: IORef Bool -> Middleware
-ping  var app req sendResponse
+ping  active app req sendResponse
     | pathInfo req == ["_ping"] = do
-        liftIO $ writeIORef var True
+        liftIO $ writeIORef active True
         sendResponse $ responseLBS status200 [] ""
     | otherwise = app req $ \res -> do
         let isHtml hs =
@@ -195,20 +196,27 @@ runUrlPort = runHostPortUrl "*4"
 -- @since 3.0.1
 runHostPortUrl :: String -> Int -> String -> Application -> IO ()
 runHostPortUrl host port url app = do
-    x <- newIORef True
-    _ <- forkIO $ Warp.runSettings
-        ( Warp.setPort port
-        $ Warp.setOnException (\_ _ -> return ())
-        $ Warp.setHost (fromString host) Warp.defaultSettings)
-        $ ping x app
-    launch port url
-    loop x
+    ready <- newEmptyMVar
+    active <- newIORef True
+    let settings =
+          Warp.setPort port $
+          Warp.setOnException (\_ _ -> return ()) $
+          Warp.setHost (fromString host) $
+          Warp.setBeforeMainLoop (putMVar ready ()) $
+          Warp.defaultSettings
+    -- Run these threads concurrently; when either one terminates or
+    -- raises an exception, the same happens to the other.
+    fmap (either id id) $ race
+      -- serve app, keep updating the activity flag
+      (Warp.runSettings settings (ping active app))
+      -- wait for server startup, launch browser, poll until server idle
+      (takeMVar ready >> launch port url >> loop active)
 
 loop :: IORef Bool -> IO ()
-loop x = do
+loop active = do
     let seconds = 120
     threadDelay $ 1000000 * seconds
-    b <- readIORef x
+    b <- readIORef active
     if b
-        then writeIORef x False >> loop x
+        then writeIORef active False >> loop active
         else return ()

wai-handler-launch/wai-handler-launch.cabal

@@ -21,6 +21,7 @@ Library
                    , bytestring              >= 0.9.1.4
                    , blaze-builder           >= 0.2.1.4 && < 0.5
                    , streaming-commons
+                   , async
 
     if os(windows)
         c-sources: windows.c