Better signal handling for proxy, stern

changelog.d/3-bug-fixes/sqpit-1431

@@ -0,0 +1 @@
+Less surprising handling of SIGINT, SIGTERM for proxy, stern

libs/wai-utilities/src/Network/Wai/Utilities/Server.hs

@@ -122,8 +122,10 @@ newSettings (Server h p l m t) = do
 -- on receiving either the INT or TERM signals. After closing
 -- the listen socket, Warp will be allowed to drain existing
 -- connections up to the given number of seconds.
-runSettingsWithShutdown :: Settings -> Application -> Word16 -> IO ()
-runSettingsWithShutdown s app secs = do
+--
+-- See also: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7681
+runSettingsWithShutdown :: Settings -> Application -> Maybe Word16 -> IO ()
+runSettingsWithShutdown s app (fromMaybe defaultShutdownTime -> secs) = do
   initialization
   latch <- newEmptyMVar
   let s' = setInstallShutdownHandler (catchSignals latch) s
@@ -145,6 +147,9 @@ runSettingsWithShutdown s app secs = do
         Just (Left ex) -> throwIO ex
         _ -> cancel srv
 
+defaultShutdownTime :: Word16
+defaultShutdownTime = 30
+
 compile :: Monad m => Routes a m b -> Tree (App m)
 compile routes = Route.prepare (Route.renderer predicateError >> routes)
   where

services/brig/src/Brig/Run.hs

@@ -102,7 +102,7 @@ run o = do
   authMetrics <- Async.async (runBrigToIO e collectAuthMetrics)
   pendingActivationCleanupAsync <- Async.async (runBrigToIO e pendingActivationCleanup)
 
-  runSettingsWithShutdown s app 5 `finally` do
+  runSettingsWithShutdown s app Nothing `finally` do
     mapM_ Async.cancel emailListener
     Async.cancel internalEventListener
     mapM_ Async.cancel sftDiscovery

services/cannon/src/Cannon/Run.hs

@@ -91,6 +91,10 @@ run o = do
   void $ installHandler sigTERM (signalHandler (env e) tid) Nothing
   void $ installHandler sigINT (signalHandler (env e) tid) Nothing
   runSettings s app `finally` do
+    -- FUTUREWORK(@akshaymankar, @fisx): we may want to call `runSettingsWithShutdown` here,
+    -- but it's a sensitive change, and it looks like this is closing all the websockets at
+    -- the same time and then calling the drain script. I suspect this might be due to some
+    -- cleanup in wai.  this needs to be tested very carefully when touched.
     Async.cancel refreshMetricsThread
     L.close (applog e)
   where

services/cargohold/src/CargoHold/Run.hs

@@ -69,7 +69,7 @@ run o = lowerCodensity $ do
           (o ^. optCargohold . epPort)
           (e ^. appLogger)
           (e ^. metrics)
-    runSettingsWithShutdown s app 5
+    runSettingsWithShutdown s app Nothing
 
 mkApp :: Opts -> Codensity IO (Application, Env)
 mkApp o = Codensity $ \k ->

services/galley/src/Galley/Run.hs

@@ -81,7 +81,7 @@ run opts = lowerCodensity $ do
     void $ Codensity $ Async.withAsync $ collectAuthMetrics (env ^. monitor) (aws ^. awsEnv)
   void $ Codensity $ Async.withAsync $ runApp env deleteLoop
   void $ Codensity $ Async.withAsync $ runApp env refreshMetrics
-  lift $ finally (runSettingsWithShutdown settings app 5) (shutdown (env ^. cstate))
+  lift $ finally (runSettingsWithShutdown settings app Nothing) (shutdown (env ^. cstate))
 
 mkApp :: Opts -> Codensity IO (Application, Env)
 mkApp opts =

services/gundeck/src/Gundeck/Run.hs

@@ -62,7 +62,7 @@ run o = do
   lst <- Async.async $ Aws.execute (e ^. awsEnv) (Aws.listen throttleMillis (runDirect e . onEvent))
   wtbs <- forM (e ^. threadBudgetState) $ \tbs -> Async.async $ runDirect e $ watchThreadBudgetState m tbs 10
   wCollectAuth <- Async.async (collectAuthMetrics m (Aws._awsEnv (Env._awsEnv e)))
-  runSettingsWithShutdown s (middleware e $ mkApp e) 5 `finally` do
+  runSettingsWithShutdown s (middleware e $ mkApp e) Nothing `finally` do
     Log.info l $ Log.msg (Log.val "Shutting down ...")
     shutdown (e ^. cstate)
     Async.cancel lst

services/proxy/src/Proxy/Run.hs

@@ -25,7 +25,6 @@ import Control.Monad.Catch
 import Data.Metrics.Middleware hiding (path)
 import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware)
 import Imports hiding (head)
-import Network.Wai.Handler.Warp (runSettings)
 import Network.Wai.Utilities.Server hiding (serverPort)
 import Proxy.API (sitemap)
 import Proxy.Env
@@ -44,4 +43,4 @@ run o = do
         versionMiddleware
           . waiPrometheusMiddleware (sitemap e)
           . catchErrors (e ^. applog) [Right m]
-  runSettings s (middleware app) `finally` destroyEnv e
+  runSettingsWithShutdown s (middleware app) Nothing `finally` destroyEnv e

services/spar/src/Spar/Run.hs

@@ -98,7 +98,7 @@ runServer sparCtxOpts = do
   (wrappedApp, ctxOpts) <- mkApp sparCtxOpts
   let logger = sparCtxLogger ctxOpts
   Log.info logger . Log.msg $ "Listening on " <> shost <> ":" <> show sport
-  WU.runSettingsWithShutdown settings wrappedApp 5
+  WU.runSettingsWithShutdown settings wrappedApp Nothing
 
 mkApp :: Opts -> IO (Application, Env)
 mkApp sparCtxOpts = do

tools/stern/src/Stern/API.hs

@@ -28,6 +28,7 @@ where
 
 import Brig.Types.Intra
 import Control.Error
+import Control.Exception (finally)
 import Control.Lens ((^.))
 import Data.Aeson hiding (Error, json)
 import qualified Data.Aeson.KeyMap as KeyMap
@@ -49,7 +50,6 @@ import qualified Galley.Types.Teams.Intra as Team
 import Imports hiding (head)
 import Network.HTTP.Types
 import Network.Wai
-import Network.Wai.Handler.Warp
 import qualified Network.Wai.Middleware.Gzip as GZip
 import Network.Wai.Predicate hiding (Error, reason, setStatus)
 import Network.Wai.Routing hiding (trace)
@@ -78,7 +78,7 @@ start :: Opts -> IO ()
 start o = do
   e <- newEnv o
   s <- Server.newSettings (server e)
-  runSettings s (pipeline e)
+  Server.runSettingsWithShutdown s (pipeline e) Nothing `finally` pure () -- nothing to clean up?
   where
     server e = Server.defaultServer (unpack $ stern o ^. epHost) (stern o ^. epPort) (e ^. applog) (e ^. metrics)
     pipeline e = GZip.gzip GZip.def $ serve e