core: delete unused contact silently (#3140)

src/Simplex/Chat.hs

@@ -4252,16 +4252,22 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
     xInfo c p' = void $ processContactProfileUpdate c p' True
 
     xDirectDel :: Contact -> RcvMessage -> MsgMeta -> m ()
-    xDirectDel c msg msgMeta = do
+    xDirectDel c msg msgMeta =
-      checkIntegrityCreateItem (CDDirectRcv c) msgMeta
+      if directOrUsed c
-      ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted
+        then do
-      contactConns <- withStore $ \db -> getContactConnections db userId ct'
+          checkIntegrityCreateItem (CDDirectRcv c) msgMeta
-      deleteAgentConnectionsAsync user $ map aConnId contactConns
+          ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted
-      forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
+          contactConns <- withStore $ \db -> getContactConnections db userId ct'
-      let ct'' = ct' {activeConn = (contactConn ct') {connStatus = ConnDeleted}} :: Contact
+          deleteAgentConnectionsAsync user $ map aConnId contactConns
-      ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted)
+          forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
-      toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
+          let ct'' = ct' {activeConn = (contactConn ct') {connStatus = ConnDeleted}} :: Contact
-      toView $ CRContactDeletedByContact user ct''
+          ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted)
+          toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
+          toView $ CRContactDeletedByContact user ct''
+        else do
+          contactConns <- withStore $ \db -> getContactConnections db userId c
+          deleteAgentConnectionsAsync user $ map aConnId contactConns
+          withStore' $ \db -> deleteContact db user c
 
     processContactProfileUpdate :: Contact -> Profile -> Bool -> m Contact
     processContactProfileUpdate c@Contact {profile = p} p' createItems

tests/ChatTests/Direct.hs

@@ -31,6 +31,7 @@ chatDirectTests = do
   describe "direct messages" $ do
     describe "add contact and send/receive message" testAddContact
     it "deleting contact deletes profile" testDeleteContactDeletesProfile
+    it "unused contact is deleted silently" testDeleteUnusedContactSilent
     it "direct message quoted replies" testDirectMessageQuotedReply
     it "direct message update" testDirectMessageUpdate
     it "direct message edit history" testDirectMessageEditHistory
@@ -214,6 +215,42 @@ testDeleteContactDeletesProfile =
       (bob </)
       bob `hasContactProfiles` ["bob"]
 
+testDeleteUnusedContactSilent :: HasCallStack => FilePath -> IO ()
+testDeleteUnusedContactSilent =
+  testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
+    \alice bob cath -> do
+      createGroup3 "team" alice bob cath
+      bob ##> "/contacts"
+      bob <### ["alice (Alice)", "cath (Catherine)"]
+      bob `hasContactProfiles` ["bob", "alice", "cath"]
+      cath ##> "/contacts"
+      cath <### ["alice (Alice)", "bob (Bob)"]
+      cath `hasContactProfiles` ["cath", "alice", "bob"]
+      -- bob deletes cath, cath's bob contact is deleted silently
+      bob ##> "/d cath"
+      bob <## "cath: contact is deleted"
+      bob ##> "/contacts"
+      bob <## "alice (Alice)"
+      threadDelay 50000
+      cath ##> "/contacts"
+      cath <## "alice (Alice)"
+      -- group messages work
+      alice #> "#team hello"
+      concurrentlyN_
+        [ bob <# "#team alice> hello",
+          cath <# "#team alice> hello"
+        ]
+      bob #> "#team hi there"
+      concurrentlyN_
+        [ alice <# "#team bob> hi there",
+          cath <# "#team bob> hi there"
+        ]
+      cath #> "#team hey"
+      concurrentlyN_
+        [ alice <# "#team cath> hey",
+          bob <# "#team cath> hey"
+        ]
+
 testDirectMessageQuotedReply :: HasCallStack => FilePath -> IO ()
 testDirectMessageQuotedReply =
   testChat2 aliceProfile bobProfile $