smp server: graceful shutdown on SIGINT (#1360)

* smp-server: graceful shutdown on SIGINT

* .501

* clean up

* remove version

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>

Author: dpwiz

apps/smp-server/web/Static.hs

@@ -42,23 +42,22 @@ serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
     WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app
   where
     app = staticFiles webStaticPath
-    mkSettings port = W.setPort port W.defaultSettings
+    mkSettings port = W.setPort port warpSettings
 
 -- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
 attachStaticFiles :: FilePath -> (AttachHTTP -> IO ()) -> IO ()
 attachStaticFiles path action =
   -- Initialize global internal state for http server.
-  WI.withII settings $ \ii -> do
+  WI.withII warpSettings $ \ii -> do
     action $ \socket cxt -> do
       -- Initialize internal per-connection resources.
       addr <- getPeerName socket
       withConnection addr cxt $ \(conn, transport) ->
         withTimeout ii conn $ \th ->
           -- Run Warp connection handler to process HTTP requests for static files.
-          WI.serveConnection conn ii th addr transport settings app
+          WI.serveConnection conn ii th addr transport warpSettings app
   where
     app = staticFiles path
-    settings = W.defaultSettings
     -- from warp-tls
     withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
     -- from warp
@@ -69,6 +68,9 @@ attachStaticFiles path action =
     -- shared clean up
     terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
 
+warpSettings :: W.Settings
+warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings
+
 staticFiles :: FilePath -> Application
 staticFiles root = S.staticApp settings
   where

src/Simplex/Messaging/Server.hs

@@ -53,6 +53,7 @@ import qualified Data.ByteString.Builder as BLD
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Dynamic (toDyn)
 import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.IORef
@@ -71,6 +72,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
 import Data.Typeable (cast)
+import GHC.Conc.Signal
 import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
 import GHC.TypeLits (KnownNat)
@@ -149,9 +151,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
         : sendPendingEvtsThread s
         : receiveFromProxyAgent pa
         : expireNtfsThread cfg
+        : sigIntHandlerThread
         : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
     )
-    `finally` withLock' (savingLock s) "final" (saveServer False >> closeServer)
+    `finally` stopServer s
   where
     runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
     runServer (tcpPort, ATransport t, addHTTP) = do
@@ -175,6 +178,22 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT
           runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
     fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
 
+    sigIntHandlerThread :: M ()
+    sigIntHandlerThread = do
+      flagINT <- newEmptyTMVarIO
+      let sigINT = 2 -- CONST_SIGINT value
+          sigIntAction = \_ptr -> atomically $ void $ tryPutTMVar flagINT ()
+          sigIntHandler = Just (sigIntAction, toDyn ())
+      void $ liftIO $ setHandler sigINT sigIntHandler
+      atomically $ readTMVar flagINT
+      logInfo "Received SIGINT, stopping server..."
+
+    stopServer :: Server -> M ()
+    stopServer s = do
+      logInfo "Saving server state..."
+      withLock' (savingLock s) "final" $ saveServer False >> closeServer
+      logInfo "Server stopped"
+
     saveServer :: Bool -> M ()
     saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerNtfs >> saveServerStats
 

src/Simplex/Messaging/Server/Main.hs

@@ -14,6 +14,7 @@
 module Simplex.Messaging.Server.Main where
 
 import Control.Concurrent.STM
+import Control.Exception (finally)
 import Control.Logger.Simple
 import Control.Monad
 import Data.ByteString.Char8 (ByteString)
@@ -280,13 +281,16 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       case webStaticPath' of
         Just path | sharedHTTP -> do
           runWebServer path Nothing ServerInformation {config, information}
-          attachStaticFiles path $ \attachHTTP -> runSMPServer cfg $ Just attachHTTP
+          attachStaticFiles path $ \attachHTTP -> do
+            logDebug "Allocated web server resources"
+            runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
         Just path -> do
           runWebServer path webHttpsParams' ServerInformation {config, information}
           runSMPServer cfg Nothing
         Nothing -> do
           logWarn "No server static path set"
           runSMPServer cfg Nothing
+      logDebug "Bye"
       where
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini