@@ -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)
@@ -33,9 +34,9 @@ import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)
3334import qualified Data.Streaming.Zlib as Z
3435
3536ping :: IORef Bool -> Middleware
36−ping var app req sendResponse
37+ping active app req sendResponse
3738 | pathInfo req == ["_ping"] = do
38− liftIO $ writeIORef var True
39+ liftIO $ writeIORef active True
3940 sendResponse $ responseLBS status200 [] ""
4041 | otherwise = app req $ \res -> do
4142 let isHtml hs =
@@ -195,20 +196,27 @@ runUrlPort = runHostPortUrl "*4"
195196-- @since 3.0.1
196197runHostPortUrl :: String -> Int -> String -> Application -> IO ()
197198runHostPortUrl host port url app = do
198− x <- newIORef True
199− _ <- forkIO $ Warp.runSettings
200− ( Warp.setPort port
201− $ Warp.setOnException (\_ _ -> return ())
202− $ Warp.setHost (fromString host) Warp.defaultSettings)
203− $ ping x app
204− launch port url
205− loop x
199+ ready <- newEmptyMVar
200+ active <- newIORef True
201+ let settings =
202+ Warp.setPort port $
203+ Warp.setOnException (\_ _ -> return ()) $
204+ Warp.setHost (fromString host) $
205+ Warp.setBeforeMainLoop (putMVar ready ()) $
206+ Warp.defaultSettings
207+ -- Run these threads concurrently; when either one terminates or
208+ -- raises an exception, the same happens to the other.
209+ fmap (either id id) $ race
210+ -- serve app, keep updating the activity flag
211+ (Warp.runSettings settings (ping active app))
212+ -- wait for server startup, launch browser, poll until server idle
213+ (takeMVar ready >> launch port url >> loop active)
206214
207215loop :: IORef Bool -> IO ()
208−loop x = do
216+loop active = do
209217 let seconds = 120
210218 threadDelay $ 1000000 * seconds
211− b <- readIORef x
219+ b <- readIORef active
212220 if b
213− then writeIORef x False >> loop x
221+ then writeIORef active False >> loop active
214222 else return ()