Add an optional graceful shutdown timeout

For servers with long-lived (or infinite lived) connections, waiting for
graceful shutdown can block the server indefinitely. A new setting is
added, which allows for a time (in seconds) to be applied when
commencing a graceful shutdown.

warp/Network/Wai/Handler/Warp.hs

@@ -70,12 +70,14 @@ module Network.Wai.Handler.Warp (
   , setSlowlorisSize
   , setHTTP2Disabled
   , setLogger
+  , setGracefulShutdownTimeout
     -- ** Getters
   , getPort
   , getHost
   , getOnOpen
   , getOnClose
   , getOnException
+  , getGracefulShutdownTimeout
     -- ** Exception handler
   , defaultOnException
   , defaultShouldDisplayException
@@ -244,6 +246,10 @@ getOnClose = settingsOnClose
 getOnException :: Settings -> Maybe Request -> SomeException -> IO ()
 getOnException = settingsOnException
 
+-- | Get the graceful shutdown timeout
+getGracefulShutdownTimeout :: Settings -> Maybe Int
+getGracefulShutdownTimeout = settingsGracefulShutdownTimeout
+
 -- | A code to install shutdown handler.
 --
 -- For instance, this code should set up a UNIX signal
@@ -347,6 +353,13 @@ setLogger :: (Request -> H.Status -> Maybe Integer -> IO ())
           -> Settings -> Settings
 setLogger lgr y = y { settingsLogger = lgr }
 
+-- | Set the graceful shutdown timeout. A timeout of `Nothing' will
+-- wait indefinitely, and a number, if provided, will be treated as seconds
+-- to wait for requests to finish, before shutting down the server entirely.
+setGracefulShutdownTimeout :: Maybe Int
+                           -> Settings -> Settings
+setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }
+
 -- | Explicitly pause the slowloris timeout.
 --
 -- This is useful for cases where you partially consume a request body. For

warp/Network/Wai/Handler/Warp/Run.hs

@@ -45,6 +45,7 @@ import qualified Network.Wai.Handler.Warp.Timeout as T
 import Network.Wai.Handler.Warp.Types
 import Network.Wai.Internal (ResponseReceived (ResponseReceived))
 import System.Environment (getEnvironment)
+import System.Timeout (timeout)
 
 #if WINDOWS
 import Network.Wai.Handler.Warp.Windows
@@ -218,7 +219,7 @@ acceptConnection set getConnMaker app counter ii0 = do
     -- ensure that no async exception is throw between the call to
     -- acceptNewConnection and the registering of connClose.
     void $ mask_ acceptLoop
-    gracefulShutdown counter
+    gracefulShutdown set counter
   where
     acceptLoop = do
         -- Allow async exceptions before receiving the next connection maker.
@@ -495,5 +496,11 @@ setSocketCloseOnExec _ = return ()
 setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket
 #endif
 
-gracefulShutdown :: Counter -> IO ()
-gracefulShutdown counter = waitForZero counter
+gracefulShutdown :: Settings -> Counter -> IO ()
+gracefulShutdown set counter =
+    case settingsGracefulShutdownTimeout set of
+        Nothing ->
+            waitForZero counter
+        (Just seconds) ->
+            void (timeout (seconds * microsPerSecond) (waitForZero counter))
+            where microsPerSecond = 1000000

warp/Network/Wai/Handler/Warp/Settings.hs

@@ -101,6 +101,9 @@ data Settings = Settings
       -- ^ A log function. Default: no action.
       --
       -- Since 3.X.X.
+    , settingsGracefulShutdownTimeout :: Maybe Int
+      -- ^ An optional timeout to limit the time (in seconds) waiting for
+      -- a graceful shutdown of the web server.
     }
 
 -- | Specify usage of the PROXY protocol.
@@ -135,6 +138,7 @@ defaultSettings = Settings
     , settingsSlowlorisSize = 2048
     , settingsHTTP2Enabled = True
     , settingsLogger = \_ _ _ -> return ()
+    , settingsGracefulShutdownTimeout = Nothing
     }
 
 -- | Apply the logic provided by 'defaultOnException' to determine if an