[SOLVED] How do I cause a WARP server to terminate?

How do I cause a WARP server to terminate?

I have an HTTP application server that needs to exit when handling a certain request under certain conditions (in order to be restarted by a supervisor).

Given a main like:

import Network.Wai.Handler.Warp (run)

main :: IO ()
main = do
  config <- readConfig
  run (portNumber config) (makeApp config)

and a handler something like:

livenessServer1 :: UTCTime -> FilePath -> Server LivenessProbeAPI1
livenessServer1 initialModificationTime monitorPath = do
  mtime <- liftIO $ getModificationTime monitorPath
  case mtime == initialModificationTime of
    True  -> return $ Liveness initialModificationTime mtime
    False -> throwError $ err500 { errBody = "File modified." }

How do I cause the process to end after delivering the 500 response?

Solution

I'm on my phone right now, so I can't type exact code for you. But the basic idea is to throw your Warp thread an async exception. That may sound complicated, but the easiest way to approach it is to use the race function from the async library. Something like this:

toExitVar <- newEmptyMVar
race warp (takeMVar toExitVar)

And then in your handler, when you want Warp to exit:

putMVar toExitVar ()

EDIT A day later and I'm back at my computer, here's a fully worked example:

#!/usr/bin/env stack
-- stack --resolver lts-9.0 script
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import Control.Concurrent.Async
import Control.Concurrent.MVar

main :: IO ()
main = do
toDie <- newEmptyMVar
race_ (takeMVar toDie) $ run 3000 $ \req send ->
    if pathInfo req == ["die"]
    then do
        putMVar toDie ()
        send $ responseLBS status200 [] "Goodbye!"
    else send $ responseLBS status200 [] "Still alive!"