From 6f7f5b67fbd244a35d514abf3d7cd9a805a18479 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Fri, 22 Apr 2016 10:02:26 -0700
Subject: [PATCH 1/2] don't launch if server fails; kill server on exit #537

Make the server thread and launch/monitor thread more aware of each
other, using async. Now, we won't launch a browser until the server is
ready to serve pages, and we won't launch it at all if the server fails
to start. Also we make sure to terminate the server thread whenever the
main thread terminates, eg from ctrl-c in GHCI.
---
 .../Network/Wai/Handler/Launch.hs             | 26 ++++++++++++-------
 wai-handler-launch/wai-handler-launch.cabal   |  1 +
 2 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/wai-handler-launch/Network/Wai/Handler/Launch.hs b/wai-handler-launch/Network/Wai/Handler/Launch.hs
index 0b3d3ea8..41fa2467 100644
--- a/wai-handler-launch/Network/Wai/Handler/Launch.hs
+++ b/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)
@@ -192,14 +193,21 @@ runUrlPort = runHostPortUrl "*4"
 
 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
diff --git a/wai-handler-launch/wai-handler-launch.cabal b/wai-handler-launch/wai-handler-launch.cabal
index e90fb360..a1bdd075 100644
--- a/wai-handler-launch/wai-handler-launch.cabal
+++ b/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

From 8ee4d4ac47c948d979733c853068c43d733aefc5 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Thu, 28 Apr 2016 14:16:38 -0700
Subject: [PATCH 2/2] name the other flag, too #537

---
 wai-handler-launch/Network/Wai/Handler/Launch.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/wai-handler-launch/Network/Wai/Handler/Launch.hs b/wai-handler-launch/Network/Wai/Handler/Launch.hs
index 41fa2467..8fd7f1ed 100644
--- a/wai-handler-launch/Network/Wai/Handler/Launch.hs
+++ b/wai-handler-launch/Network/Wai/Handler/Launch.hs
@@ -34,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 =
@@ -210,10 +210,10 @@ runHostPortUrl host port url app = do
       (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 ()