core: batch connection deletion events (#5573)

* core: batch connection deletion events

* simplexmq

cabal.project

@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: eda9e36c826f8e9f9d984e4d25612e7a6abddace
+    tag: b3c8358a43b7a15ba38e0a0385813172d47989c7
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."eda9e36c826f8e9f9d984e4d25612e7a6abddace" = "05z805iwnbffdkllga3pp7hfbs13zsipymgxqmlcpjrnq9g9i97l";
+  "https://github.com/simplex-chat/simplexmq.git"."b3c8358a43b7a15ba38e0a0385813172d47989c7" = "173f9hji6a5d6wkyys3y6yxv42ycray6b8dmwiswwnjyrnasdq6k";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
   "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

src/Simplex/Chat/Controller.hs

@@ -824,8 +824,8 @@ data ChatResponse
   | CRContactDisabled {user :: User, contact :: Contact}
   | CRConnectionDisabled {connectionEntity :: ConnectionEntity}
   | CRConnectionInactive {connectionEntity :: ConnectionEntity, inactive :: Bool}
-  | CRAgentRcvQueueDeleted {agentConnId :: AgentConnId, server :: SMPServer, agentQueueId :: AgentQueueId, agentError_ :: Maybe AgentErrorType}
+  | CRAgentRcvQueuesDeleted {deletedRcvQueues :: NonEmpty DeletedRcvQueue}
-  | CRAgentConnDeleted {agentConnId :: AgentConnId}
+  | CRAgentConnsDeleted {agentConnIds :: NonEmpty AgentConnId}
   | CRAgentUserDeleted {agentUserId :: Int64}
   | CRMessageError {user :: User, severity :: Text, errorMessage :: Text}
   | CRChatCmdError {user_ :: Maybe User, chatError :: ChatError}
@@ -836,6 +836,14 @@ data ChatResponse
   | CRCustomChatResponse {user_ :: Maybe User, response :: Text}
   deriving (Show)
 
+data DeletedRcvQueue = DeletedRcvQueue
+  { agentConnId :: AgentConnId,
+    server :: SMPServer,
+    agentQueueId :: AgentQueueId,
+    agentError_ :: Maybe AgentErrorType
+  }
+  deriving (Show)
+
 -- some of these can only be used as command responses
 allowRemoteEvent :: ChatResponse -> Bool
 allowRemoteEvent = \case
@@ -874,8 +882,8 @@ logResponseToFile = \case
   CRHostConnected {} -> True
   CRHostDisconnected {} -> True
   CRConnectionDisabled {} -> True
-  CRAgentRcvQueueDeleted {} -> True
+  CRAgentRcvQueuesDeleted {} -> True
-  CRAgentConnDeleted {} -> True
+  CRAgentConnsDeleted {} -> True
   CRAgentUserDeleted {} -> True
   CRChatCmdError {} -> True
   CRChatError {} -> True
@@ -1597,6 +1605,8 @@ $(JQ.deriveJSON defaultJSON ''SwitchProgress)
 
 $(JQ.deriveJSON defaultJSON ''RatchetSyncProgress)
 
+$(JQ.deriveJSON defaultJSON ''DeletedRcvQueue)
+
 $(JQ.deriveJSON defaultJSON ''ServerAddress)
 
 $(JQ.deriveJSON defaultJSON ''ParsedServerAddress)
@@ -1609,29 +1619,6 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
 $(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
 #endif
 
--- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
---   parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
-
--- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
---   parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
-
--- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
---   toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
---   toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
-
--- instance FromJSON AUserProtoServers where
---   parseJSON v = J.withObject "AUserProtoServers" parse v
---     where
---       parse o = do
---         AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
---         case userProtocol p of
---           Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
---           Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
-
--- instance ToJSON AUserProtoServers where
---   toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
---   toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
-
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
 
 $(JQ.deriveJSON defaultJSON ''RemoteCtrlInfo)

src/Simplex/Chat/Library/Subscriber.hs

@@ -92,10 +92,12 @@ smallGroupsRcptsMemLimit :: Int
 smallGroupsRcptsMemLimit = 20
 
 processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
-processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
+processAgentMessage _ _ (DEL_RCVQS delQs) =
-  toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
+  toView $ CRAgentRcvQueuesDeleted $ L.map rcvQ delQs
-processAgentMessage _ connId DEL_CONN =
+  where
-  toView $ CRAgentConnDeleted (AgentConnId connId)
+    rcvQ (connId, server, rcvId, err_) = DeletedRcvQueue (AgentConnId connId) server (AgentQueueId rcvId) err_
+processAgentMessage _ _ (DEL_CONNS connIds) =
+  toView $ CRAgentConnsDeleted $ L.map AgentConnId connIds
 processAgentMessage _ "" (ERR e) =
   toView $ CRChatError Nothing $ ChatErrorAgent e Nothing
 processAgentMessage corrId connId msg = do

src/Simplex/Chat/View.hs

@@ -435,14 +435,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
   CRContactDisabled u c -> ttyUser u ["[" <> ttyContact' c <> "] connection is disabled, to enable: " <> highlight ("/enable " <> viewContactName c) <> ", to delete: " <> highlight ("/d " <> viewContactName c)]
   CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
   CRConnectionInactive entity inactive -> viewConnectionEntityInactive entity inactive
-  CRAgentRcvQueueDeleted acId srv aqId err_ ->
+  CRAgentRcvQueuesDeleted delQs -> ["completed deleting rcv queues: " <> sShow (length delQs) | logLevel <= CLLInfo]
-    [ ("completed deleting rcv queue, agent connection id: " <> sShow acId)
+  CRAgentConnsDeleted acIds -> ["completed deleting connections: " <> sShow (length acIds) | logLevel <= CLLInfo]
-        <> (", server: " <> sShow srv)
-        <> (", agent queue id: " <> sShow aqId)
-        <> maybe "" (\e -> ", error: " <> sShow e) err_
-      | logLevel <= CLLInfo
-    ]
-  CRAgentConnDeleted acId -> ["completed deleting connection, agent connection id: " <> sShow acId | logLevel <= CLLInfo]
   CRAgentUserDeleted auId -> ["completed deleting user" <> if logLevel <= CLLInfo then ", agent user id: " <> sShow auId else ""]
   CRMessageError u prefix err -> ttyUser u [plain prefix <> ": " <> plain err | prefix == "error" || logLevel <= CLLWarning]
   CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError True logLevel testView e