Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Simple Warp server that can be gracefully shutdown over HTTP.
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
import Network.HTTP.Types
import Network.Wai as Wai
import Network.Wai.Handler.Warp as Warp
app :: TMVar () -> Application
app shutdown req = liftIO . atomically $ do
let textResponse = return . responseLBS ok200 [(hContentType, "text/plain")]
shouldRun <- isEmptyTMVar shutdown
case (shouldRun, pathInfo req) of
-- if the TMVar is full we're shutting down
(False, _) -> return $ responseLBS serviceUnavailable503 [] ""
-- if it's not full and a shutdown was requested, signal the shutdown TMVar
(True, ["shutdownByMVar"]) -> putTMVar shutdown () >> textResponse "shutting down!"
-- otherwise handle the request as normal...
_ -> textResponse "ok"
main :: IO ()
main = do
-- The pair of (shutdown, activeConnections) will be used to signal our exit criteria
shutdown <- newEmptyTMVarIO
activeConnections <- newTVarIO (0 :: Int)
-- Hook the OnOpen/OnClose events to manage the activeConnection count
let settings = defaultSettings
{ settingsOnOpen = atomically $ modifyTVar' activeConnections (+1)
, settingsOnClose = atomically $ modifyTVar' activeConnections (subtract 1)
}
_ <- forkIO $ Warp.runSettings settings (app shutdown)
-- Once the shutdown has been triggered, wait until the active connection count
-- drops to zero before exiting.
atomically $ do
takeTMVar shutdown
conns <- readTVar activeConnections
when (conns /= 0)
retry
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.