gracefully close sockets on client disconnection (#373)

* gracefully close sockets on client disconnection

* remove -threaded

apps/ntf-server/Main.hs

@@ -5,7 +5,7 @@ module Main where
 import Control.Logger.Simple
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
 import Simplex.Messaging.Notifications.Server (runNtfServer)
-import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
 import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI)
 import System.FilePath (combine)
@@ -66,7 +66,7 @@ ntfServerCLIConfig =
                 pushQSize = 128,
                 smpAgentCfg = defaultSMPClientAgentConfig,
                 apnsConfig = defaultAPNSPushClientConfig,
-                inactiveClientExpiration = Just defaultInactiveClientExpiration,
+                inactiveClientExpiration = Nothing,
                 caCertificateFile = caCrtFile,
                 privateKeyFile = serverKeyFile,
                 certificateFile = serverCrtFile

apps/smp-server/Main.hs

@@ -65,9 +65,9 @@ smpServerCLIConfig =
               <> "websockets: off\n\n"
               <> "[INACTIVE_CLIENTS]\n\
                  \# TTL and interval to check inactive clients\n\
-                 \disconnect: on\n"
-              <> ("ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
-              <> ("check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
+                 \disconnect: off\n"
+              <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
+              <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
           mkServerConfig = \storeLogFile transports ini ->
             ServerConfig
               { transports,

src/Simplex/Messaging/Transport/Server.hs

@@ -41,27 +41,27 @@ runTransportServer started port serverParams server = do
     E.bracket
       (startTCPServer started port)
       (closeServer started clients)
-      $ \sock -> forever $ do
-        (connSock, _) <- accept sock
-        tid <- forkIO $ connectClient u connSock `catchAll_` close connSock `catchAll_` pure ()
+      $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
+        -- catchAll_ is needed here in case the connection was closed earlier
+        tid <- forkFinally (connectClient u conn) (const . liftIO $ gracefulClose conn 5000 `catchAll_` pure ())
         atomically . modifyTVar' clients $ S.insert tid
   where
     connectClient :: UnliftIO m -> Socket -> IO ()
-    connectClient u connSock =
+    connectClient u conn =
       E.bracket
-        (connectTLS serverParams connSock >>= getServerConnection)
+        (connectTLS serverParams conn >>= getServerConnection)
         closeConnection
         (unliftIO u . server)
 
+-- | Run TCP server without TLS - only used in SimpleX Chat
 runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
 runTCPServer started port server = do
   clients <- newTVarIO S.empty
   E.bracket
     (startTCPServer started port)
     (closeServer started clients)
-    $ \sock -> forever $ do
-      (connSock, _) <- accept sock
-      tid <- forkIO $ server connSock `catchAll_` pure ()
+    $ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
+      tid <- forkFinally (server conn) (const $ gracefulClose conn 5000)
       atomically . modifyTVar' clients $ S.insert tid
 
 closeServer :: TMVar Bool -> TVar (Set ThreadId) -> Socket -> IO ()