server: control port (#804)

* server: control port

* do not remove messages when saving via control port

* remove unused record fields

* fix tests

src/Simplex/Messaging/Server/Control.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Server.Control where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Simplex.Messaging.Encoding.String
+
+data ControlProtocol
+  = CPSuspend
+  | CPResume
+  | CPClients
+  | CPStats
+  | CPSave
+  | CPHelp
+  | CPQuit
+
+instance StrEncoding ControlProtocol where
+  strEncode = \case
+    CPSuspend -> "suspend"
+    CPResume -> "resume"
+    CPClients -> "clients"
+    CPStats -> "stats"
+    CPSave -> "save"
+    CPHelp -> "help"
+    CPQuit -> "quit"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "suspend" -> pure CPSuspend
+      "resume" -> pure CPResume
+      "clients" -> pure CPClients
+      "stats" -> pure CPStats
+      "save" -> pure CPSave
+      "help" -> pure CPHelp
+      "quit" -> pure CPQuit
+      _ -> fail "bad ControlProtocol command"

src/Simplex/Messaging/Server/Env/STM.hs

@@ -19,6 +19,7 @@ import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural
+import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Crypto (KeyHash (..))
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Expiration
@@ -70,7 +71,9 @@ data ServerConfig = ServerConfig
     -- | SMP client-server protocol version range
     smpServerVRange :: VersionRange,
     -- | TCP transport config
-    transportConfig :: TransportServerConfig
+    transportConfig :: TransportServerConfig,
+    -- | run listener on control port
+    controlPort :: Maybe ServiceName
   }
 
 defMsgExpirationDays :: Int64
@@ -106,7 +109,8 @@ data Server = Server
   { subscribedQ :: TQueue (RecipientId, Client),
     subscribers :: TMap RecipientId Client,
     ntfSubscribedQ :: TQueue (NotifierId, Client),
-    notifiers :: TMap NotifierId Client
+    notifiers :: TMap NotifierId Client,
+    savingLock :: Lock
   }
 
 data Client = Client
@@ -133,7 +137,8 @@ newServer = do
   subscribers <- TM.empty
   ntfSubscribedQ <- newTQueue
   notifiers <- TM.empty
-  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
+  savingLock <- createLock
+  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
 
 newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
 newClient qSize thVersion sessionId ts = do

src/Simplex/Messaging/Server/Main.hs

@@ -130,7 +130,8 @@ smpServerCLI cfgPath logPath =
                 <> ("host: " <> host <> "\n")
                 <> ("port: " <> defaultServerPort <> "\n")
                 <> "log_tls_errors: off\n\
-                   \websockets: off\n\n\
+                   \websockets: off\n\
+                   \# control_port: 5224\n\n\
                    \[INACTIVE_CLIENTS]\n\
                    \# TTL and interval to check inactive clients\n\
                    \disconnect: off\n"
@@ -202,7 +203,8 @@ smpServerCLI cfgPath logPath =
               transportConfig =
                 defaultTransportServerConfig
                   { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  }
+                  },
+              controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini
             }
 
 data CliCommand

src/Simplex/Messaging/Server/MsgStore/STM.hs

@@ -13,6 +13,7 @@ module Simplex.Messaging.Server.MsgStore.STM
     getMsgQueue,
     delMsgQueue,
     flushMsgQueue,
+    snapshotMsgQueue,
     writeMsg,
     tryPeekMsg,
     peekMsg,
@@ -62,6 +63,14 @@ delMsgQueue st rId = TM.delete rId st
 flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
 flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
 
+snapshotMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+snapshotMsgQueue st rId  = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . msgQueue)
+  where
+    snapshotTQueue q = do
+      msgs <- flushTQueue q
+      mapM_ (writeTQueue q) msgs
+      pure msgs
+
 writeMsg :: MsgQueue -> Message -> STM (Maybe Message)
 writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do
   canWrt <- readTVar canWrite

src/Simplex/Messaging/Server/Stats.hs

@@ -94,7 +94,7 @@ setServerStats s d = do
   writeTVar (msgRecvNtf s) $! _msgRecvNtf d
   setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
   writeTVar (qCount s) $! _qCount d
-  writeTVar (msgCount s) $! _qCount d
+  writeTVar (msgCount s) $! _msgCount d
 
 instance StrEncoding ServerStatsData where
   strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf} =