How to make the WARP server shut down?

Question

I have an HTTP application server that needs to exit when processing a specific request under certain conditions (to restart the supervisor).

Given the main thing:

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 to get a process to shut down after a 500 response?

Answer 1

Now I am on my phone, so I can’t dial the exact code for you. But the main idea is to cut out the Warp stream as an async exception. It may seem complicated, but the easiest way to get closer to it is to use the race function from the asynchronous library. Something like that:

toExitVar <- newEmptyMVar
race warp (takeMVar toExitVar)

, , Warp :

putMVar toExitVar ()

, , :

#!/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!"