@@ -15,7 +15,8 @@ import qualified Network.Wai.Handler.Warp as Warp
1515import Data.IORef
1616import Data.Monoid (mappend)
1717import Data.String (fromString)
18−import Control.Concurrent (forkIO, threadDelay)
18+import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar)
19+import Control.Concurrent.Async (race)
1920import Control.Monad.IO.Class (liftIO)
2021import Control.Monad (unless)
2122import Control.Exception (throwIO)
@@ -192,14 +193,21 @@ runUrlPort = runHostPortUrl "*4"
192193
193194runHostPortUrl :: String -> Int -> String -> Application -> IO ()
194195runHostPortUrl host port url app = do
195− x <- newIORef True
196− _ <- forkIO $ Warp.runSettings
197− ( Warp.setPort port
198− $ Warp.setOnException (\_ _ -> return ())
199− $ Warp.setHost (fromString host) Warp.defaultSettings)
200− $ ping x app
201− launch port url
202− loop x
196+ ready <- newEmptyMVar
197+ active <- newIORef True
198+ let settings =
199+ Warp.setPort port $
200+ Warp.setOnException (\_ _ -> return ()) $
201+ Warp.setHost (fromString host) $
202+ Warp.setBeforeMainLoop (putMVar ready ()) $
203+ Warp.defaultSettings
204+ -- Run these threads concurrently; when either one terminates or
205+ -- raises an exception, the same happens to the other.
206+ fmap (either id id) $ race
207+ -- serve app, keep updating the activity flag
208+ (Warp.runSettings settings (ping active app))
209+ -- wait for server startup, launch browser, poll until server idle
210+ (takeMVar ready >> launch port url >> loop active)
203211
204212loop :: IORef Bool -> IO ()
205213loop x = do