Treat a warp webserver as a resource in the bracket pattern which can be created and safely terminated multiple times ina program.

withwarp.hs

{-# LANGUAGE OverloadedStrings #-} -- only used in the example

import Control.Concurrent (forkIO, forkFinally, killThread)
import Control.Concurrent.MVar (newEmptyMVar, tryPutMVar, takeMVar)
import Control.Monad (void)
import Control.Exception (mask, uninterruptibleMask_, onException, finally)
import Network.HTTP.Types.Status (status200) -- only used in the example
import Network.Wai (Application, responseLBS) -- only used in the example
import Network.Wai.Handler.Warp (Settings, runSettings, defaultSettings, setHost, setInstallShutdownHandler, setGracefulShutdownTimeout)




-- | Possibly like @async:Control.Async.withAsync@
--
-- Not used below, but hopefully a helpful reference for what's happening below.
withForkIO :: IO () -> IO a -> IO a
withForkIO child parent =
    mask $ \restore -> do
        t <- forkIO $ restore child
        r <- restore parent
                `onException` uninterruptibleMask_ (killThread t)
        uninterruptibleMask_ (killThread t)
        return r




-- | Shut down a warp server cleanly when the @action@ argument returns.
withWarp :: Settings -> Application -> IO a -> IO a
withWarp settings application action = do
    let send sig = void $ tryPutMVar sig ()
    let wait sig = void $ takeMVar sig

    shutdownBegin <- newEmptyMVar
    -- In a background thread, the shutdown handler waits for the shutdownBegin
    -- signal and then closes the listening socket, which starts a
    -- graceful-shutdown.
    let installShutdownHandler close =
            void $ forkFinally
                (wait shutdownBegin)
                (const close)
    let settings' = setInstallShutdownHandler installShutdownHandler settings

    shutdownEnd <- newEmptyMVar
    -- The main thread signals shutdownBegin when it is done and then waits for
    -- shutdownEnd. The warp thread enters graceful-shutdown when shutdownBegin
    -- is received and signals shutdownEnd when graceful-shutdown is complete.
    mask $ \restore -> do
        w <- forkFinally -- forkIO is not interruptible
            (restore $ runSettings settings' application)
            (const $ send shutdownEnd) -- tryPutMVar is not interruptible
        finally
            (restore action)
            $do send shutdownBegin -- tryPutMVar is not interruptible
                uninterruptibleMask_ $ wait shutdownEnd -- takeMVar is interruptible
                uninterruptibleMask_ $ killThread w -- throwTo is interruptible




example :: Application
example request respond = do
    putStrLn $ "doing work for request:" ++ show request
    respond $ responseLBS status200 [] "done"

main :: IO ()
main = do
    let local
            = setHost "localhost"
            . setGracefulShutdownTimeout (Just 3)
            $ defaultSettings
    withWarp local example $ do
        putStrLn "press enter to stop the first server cleanly"
        _ <- getLine
        return ()
    putStrLn "next we will try to start up the second server, but it won't work if the first is still bound to the port"
    withWarp local example $ do
        putStrLn "press enter to stop the second server cleanly"
        _ <- getLine
        return ()