core: optimize group deletion (delays deletion of unused contacts) (#2560)

* core: optimize group deletion (wip)

* delay deletion of unused contacts

* clean up, fix test

* rename field

* remove from type, more checks, remove ctx

* remove space

* rename functions

* rename

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

simplex-chat.cabal

@@ -100,6 +100,7 @@ library
       Simplex.Chat.Migrations.M20230519_item_deleted_ts
       Simplex.Chat.Migrations.M20230526_indexes
       Simplex.Chat.Migrations.M20230529_indexes
+      Simplex.Chat.Migrations.M20230608_deleted_contacts
       Simplex.Chat.Mobile
       Simplex.Chat.Mobile.WebRTC
       Simplex.Chat.Options

src/Simplex/Chat.hs

@@ -121,6 +121,7 @@ defaultChatConfig =
       testView = False,
       initialCleanupManagerDelay = 30 * 1000000, -- 30 seconds
       cleanupManagerInterval = 30 * 60, -- 30 minutes
+      cleanupManagerStepDelay = 3 * 1000000, -- 3 seconds
       ciExpirationInterval = 30 * 60 * 1000000 -- 30 minutes
     }
 
@@ -867,7 +868,7 @@ processChatCommand = \case
                   Just _ -> pure []
                   Nothing -> do
                     conns <- withStore $ \db -> getContactConnections db userId ct
-                    withStore' (\db -> deleteContactWithoutGroups db user ct)
+                    withStore' (\db -> setContactDeleted db user ct)
                       `catchError` (toView . CRChatError (Just user))
                     pure $ map aConnId conns
     CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
@@ -2358,15 +2359,16 @@ cleanupManager :: forall m. ChatMonad m => m ()
 cleanupManager = do
   interval <- asks (cleanupManagerInterval . config)
   runWithoutInitialDelay interval
-  delay <- asks (initialCleanupManagerDelay . config)
+  initialDelay <- asks (initialCleanupManagerDelay . config)
-  liftIO $ threadDelay' delay
+  liftIO $ threadDelay' initialDelay
+  stepDelay <- asks (cleanupManagerStepDelay . config)
   forever $ do
     flip catchError (toView . CRChatError Nothing) $ do
       waitChatStarted
       users <- withStoreCtx' (Just "cleanupManager, getUsers 1") getUsers
       let (us, us') = partition activeUser users
-      forM_ us $ cleanupUser interval
+      forM_ us $ cleanupUser interval stepDelay
-      forM_ us' $ cleanupUser interval
+      forM_ us' $ cleanupUser interval stepDelay
       cleanupMessages `catchError` (toView . CRChatError Nothing)
     liftIO $ threadDelay' $ diffToMicroseconds interval
   where
@@ -2376,13 +2378,21 @@ cleanupManager = do
       let (us, us') = partition activeUser users
       forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchError` (toView . CRChatError (Just u))
       forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchError` (toView . CRChatError (Just u))
-    cleanupUser cleanupInterval user =
+    cleanupUser cleanupInterval stepDelay user = do
       cleanupTimedItems cleanupInterval user `catchError` (toView . CRChatError (Just user))
+      liftIO $ threadDelay' stepDelay
+      cleanupDeletedContacts user `catchError` (toView . CRChatError (Just user))
+      liftIO $ threadDelay' stepDelay
     cleanupTimedItems cleanupInterval user = do
       ts <- liftIO getCurrentTime
       let startTimedThreadCutoff = addUTCTime cleanupInterval ts
       timedItems <- withStoreCtx' (Just "cleanupManager, getTimedItems") $ \db -> getTimedItems db user startTimedThreadCutoff
       forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchError` const (pure ())
+    cleanupDeletedContacts user = do
+      contacts <- withStore' (`getDeletedContacts` user)
+      forM_ contacts $ \ct ->
+        withStore' (\db -> deleteContactWithoutGroups db user ct)
+          `catchError` (toView . CRChatError (Just user))
     cleanupMessages = do
       ts <- liftIO getCurrentTime
       let cutoffTs = addUTCTime (- (30 * nominalDay)) ts
@@ -4295,7 +4305,9 @@ throwChatError = throwError . ChatError
 
 deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m ()
 deleteMembersConnections user members = do
-  let memberConns = mapMaybe (\GroupMember {activeConn} -> activeConn) members
+  let memberConns =
+        filter (\Connection {connStatus} -> connStatus /= ConnDeleted) $
+          mapMaybe (\GroupMember {activeConn} -> activeConn) members
   deleteAgentConnectionsAsync user $ map aConnId memberConns
   forM_ memberConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
 
@@ -4719,7 +4731,6 @@ withStoreCtx ctx_ action = do
   ChatController {chatStore} <- ask
   liftEitherError ChatErrorStore $ case ctx_ of
     Nothing -> withTransaction chatStore (runExceptT . action) `E.catch` handleInternal ""
-    Just _ -> withTransaction chatStore (runExceptT . action) `E.catch` handleInternal ""
     -- uncomment to debug store performance
     -- Just ctx -> do
     --   t1 <- liftIO getCurrentTime
@@ -4728,6 +4739,7 @@ withStoreCtx ctx_ action = do
     --   t2 <- liftIO getCurrentTime
     --   putStrLn $ "withStoreCtx end         :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
     --   pure r
+    Just _ -> withTransaction chatStore (runExceptT . action) `E.catch` handleInternal ""
   where
     handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
     handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr

src/Simplex/Chat/Controller.hs

@@ -112,6 +112,7 @@ data ChatConfig = ChatConfig
     testView :: Bool,
     initialCleanupManagerDelay :: Int64,
     cleanupManagerInterval :: NominalDiffTime,
+    cleanupManagerStepDelay :: Int64,
     ciExpirationInterval :: Int64 -- microseconds
   }
 

src/Simplex/Chat/Migrations/M20230608_deleted_contacts.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20230608_deleted_contacts where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230608_deleted_contacts :: Query
+m20230608_deleted_contacts =
+  [sql|
+ALTER TABLE contacts ADD COLUMN deleted INTEGER NOT NULL DEFAULT 0;
+
+CREATE INDEX msg_delivery_events_msg_delivery_id ON msg_delivery_events(msg_delivery_id);
+|]
+
+down_m20230608_deleted_contacts :: Query
+down_m20230608_deleted_contacts =
+  [sql|
+DROP INDEX msg_delivery_events_msg_delivery_id;
+
+ALTER TABLE contacts DROP COLUMN deleted;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -63,6 +63,7 @@ CREATE TABLE contacts(
   contact_used INTEGER DEFAULT 0 CHECK(contact_used NOT NULL),
   user_preferences TEXT DEFAULT '{}' CHECK(user_preferences NOT NULL),
   chat_ts TEXT,
+  deleted INTEGER NOT NULL DEFAULT 0,
   FOREIGN KEY(user_id, local_display_name)
   REFERENCES display_names(user_id, local_display_name)
   ON DELETE CASCADE
@@ -652,3 +653,6 @@ CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON msg_deliveries(
   connection_id,
   agent_ack_cmd_id
 );
+CREATE INDEX msg_delivery_events_msg_delivery_id ON msg_delivery_events(
+  msg_delivery_id
+);

src/Simplex/Chat/Store.hs

@@ -52,6 +52,8 @@ module Simplex.Chat.Store
     deleteContactConnectionsAndFiles,
     deleteContact,
     deleteContactWithoutGroups,
+    setContactDeleted,
+    getDeletedContacts,
     getContactByName,
     getContact,
     getContactIdByName,
@@ -395,6 +397,7 @@ import Simplex.Chat.Migrations.M20230511_reactions
 import Simplex.Chat.Migrations.M20230519_item_deleted_ts
 import Simplex.Chat.Migrations.M20230526_indexes
 import Simplex.Chat.Migrations.M20230529_indexes
+import Simplex.Chat.Migrations.M20230608_deleted_contacts
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Chat.Util (week)
@@ -476,7 +479,8 @@ schemaMigrations =
     ("20230511_reactions", m20230511_reactions, Just down_m20230511_reactions),
     ("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts),
     ("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes),
-    ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes)
+    ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes),
+    ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -547,7 +551,7 @@ getUsersInfo db = getUsers db >>= mapM getUserInfo
               SELECT COUNT(1)
               FROM chat_items i
               JOIN contacts ct USING (contact_id)
-              WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL)
+              WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0
             |]
             (userId, CISRcvNew)
       gCount <-
@@ -622,7 +626,7 @@ getUserByARcvFileId db aRcvFileId =
 getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User
 getUserByContactId db contactId =
   ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
-    DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ?") (Only contactId)
+    DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId)
 
 getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User
 getUserByGroupId db groupId =
@@ -711,7 +715,7 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do
             FROM contacts ct
             JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
             JOIN connections c ON c.contact_id = ct.contact_id
-            WHERE ct.user_id = ? AND c.via_contact_uri_hash = ?
+            WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0
             ORDER BY c.connection_id DESC
             LIMIT 1
           |]
@@ -757,7 +761,6 @@ getProfileById db userId profileId =
       [sql|
         SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences
         FROM contact_profiles cp
-          -- JOIN contacts ct ON cp.contact_profile_id = ct.contact_profile_id
         WHERE cp.user_id = ? AND cp.contact_profile_id = ?
       |]
       (userId, profileId)
@@ -849,6 +852,19 @@ deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDispla
   DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId)
   forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId
 
+setContactDeleted :: DB.Connection -> User -> Contact -> IO ()
+setContactDeleted db User {userId} Contact {contactId} = do
+  currentTs <- getCurrentTime
+  DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId)
+
+getDeletedContacts :: DB.Connection -> User -> IO [Contact]
+getDeletedContacts db user@User {userId} = do
+  contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId)
+  rights <$> mapM (runExceptT . getDeletedContact db user) contactIds
+
+getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact
+getDeletedContact db user contactId = getContact_ db user contactId True
+
 deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO ()
 deleteUnusedIncognitoProfileById_ db User {userId} profile_id =
   DB.executeNamed
@@ -1061,7 +1077,7 @@ getContactByName db user localDisplayName = do
 
 getUserContacts :: DB.Connection -> User -> IO [Contact]
 getUserContacts db user@User {userId} = do
-  contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ?" (Only userId)
+  contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
   rights <$> mapM (runExceptT . getContact db user) contactIds
 
 -- only used in tests
@@ -1365,7 +1381,7 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profi
             FROM contacts ct
             JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
             LEFT JOIN connections c ON c.contact_id = ct.contact_id
-            WHERE ct.user_id = ? AND ct.xcontact_id = ?
+            WHERE ct.user_id = ? AND ct.xcontact_id = ? AND ct.deleted = 0
             ORDER BY c.connection_id DESC
             LIMIT 1
           |]
@@ -1615,6 +1631,7 @@ getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalPro
           FROM contacts ct
           JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
           WHERE ct.user_id = ? AND ct.contact_id != ?
+            AND ct.deleted = 0
             AND p.display_name = ? AND p.full_name = ?
             AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?)
         |]
@@ -1657,7 +1674,7 @@ matchReceivedProbe db user@User {userId} _from@Contact {contactId} (Probe probe)
           SELECT c.contact_id
           FROM contacts c
           JOIN received_probes r ON r.contact_id = c.contact_id
-          WHERE c.user_id = ? AND r.probe_hash = ? AND r.probe IS NULL
+          WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NULL
         |]
         (userId, probeHash)
   currentTs <- getCurrentTime
@@ -1678,7 +1695,7 @@ matchReceivedProbeHash db user@User {userId} _from@Contact {contactId} (ProbeHas
         SELECT c.contact_id, r.probe
         FROM contacts c
         JOIN received_probes r ON r.contact_id = c.contact_id
-        WHERE c.user_id = ? AND r.probe_hash = ? AND r.probe IS NOT NULL
+        WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NOT NULL
       |]
       (userId, probeHash)
   currentTs <- getCurrentTime
@@ -1703,7 +1720,7 @@ matchSentProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = d
           FROM contacts c
           JOIN sent_probes s ON s.contact_id = c.contact_id
           JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id
-          WHERE c.user_id = ? AND s.probe = ? AND h.contact_id = ?
+          WHERE c.user_id = ? AND c.deleted = 0 AND s.probe = ? AND h.contact_id = ?
         |]
         (userId, probe, contactId)
   case contactIds of
@@ -1808,7 +1825,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
               p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts
             FROM contacts c
             JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
-            WHERE c.user_id = ? AND c.contact_id = ?
+            WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0
           |]
           (userId, contactId)
     toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact
@@ -1913,6 +1930,7 @@ getConnectionsContacts db agentConnIds = do
           JOIN connections c ON c.contact_id = ct.contact_id
           WHERE c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids)
             AND c.conn_type = ?
+            AND ct.deleted = 0
         |]
         (Only ConnContact)
   DB.execute_ db "DROP TABLE temp.conn_ids"
@@ -2388,7 +2406,7 @@ getContactViaMember db user@User {userId} GroupMember {groupMemberId} =
           where cc.contact_id = ct.contact_id
         )
         JOIN group_members m ON m.contact_id = ct.contact_id
-        WHERE ct.user_id = ? AND m.group_member_id = ?
+        WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
       |]
       (userId, groupMemberId)
 
@@ -2697,7 +2715,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
           FROM connections cc
           where cc.group_member_id = m.group_member_id
         )
-        WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ?
+        WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0
       |]
       (userId, contactId, userContactId)
   where
@@ -2727,7 +2745,7 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} =
         )
         JOIN groups g ON g.group_id = ct.via_group
         JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id
-        WHERE ct.user_id = ? AND m.group_member_id = ?
+        WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
       |]
       (userId, groupMemberId)
   where
@@ -3826,6 +3844,7 @@ getDirectChatPreviews_ db user@User {userId} = do
         LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id
         WHERE ct.user_id = ?
           AND ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1)
+          AND ct.deleted = 0
           AND c.connection_id = (
             SELECT cc_connection_id FROM (
               SELECT
@@ -4107,10 +4126,13 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
 getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64
 getContactIdByName db User {userId} cName =
   ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $
-    DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ?" (userId, cName)
+    DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName)
 
 getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact
-getContact db user@User {userId} contactId =
+getContact db user contactId = getContact_ db user contactId False
+
+getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
+getContact_ db user@User {userId} contactId deleted =
   ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $
     DB.query
       db
@@ -4126,6 +4148,7 @@ getContact db user@User {userId} contactId =
         JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
         LEFT JOIN connections c ON c.contact_id = ct.contact_id
         WHERE ct.user_id = ? AND ct.contact_id = ?
+          AND ct.deleted = ?
           AND c.connection_id = (
             SELECT cc_connection_id FROM (
               SELECT
@@ -4138,7 +4161,7 @@ getContact db user@User {userId} contactId =
             )
           )
       |]
-      (userId, contactId, ConnReady, ConnSndReady)
+      (userId, contactId, deleted, ConnReady, ConnSndReady)
 
 getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
 getGroupChat db user groupId pagination search_ = do
@@ -5377,7 +5400,7 @@ getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do
           FROM connections cc
           where cc.group_member_id = mh.group_member_id
         )
-        WHERE ct.user_id = ? AND ct.contact_id = ? AND mh.member_category = ?
+        WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = 0 AND mh.member_category = ?
       |]
       (userId, contactId, GCHostMember)
   where
@@ -5407,7 +5430,7 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
           FROM connections cc
           where cc.group_member_id = mh.group_member_id
         )
-        WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ?
+        WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0
       |]
       (userId, groupMemberId, GCHostMember)
   where

tests/ChatTests/Direct.hs

@@ -1327,7 +1327,7 @@ testUsersDifferentCIExpirationTTL tmp = do
 
       alice #$> ("/_get chat @4 count=100", chat, [])
   where
-    cfg = testCfg {initialCleanupManagerDelay = 0, ciExpirationInterval = 500000}
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000}
 
 testUsersRestartCIExpiration :: HasCallStack => FilePath -> IO ()
 testUsersRestartCIExpiration tmp = do
@@ -1410,7 +1410,7 @@ testUsersRestartCIExpiration tmp = do
 
       alice #$> ("/_get chat @4 count=100", chat, [])
   where
-    cfg = testCfg {initialCleanupManagerDelay = 0, ciExpirationInterval = 500000}
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000}
 
 testEnableCIExpirationOnlyForOneUser :: HasCallStack => FilePath -> IO ()
 testEnableCIExpirationOnlyForOneUser tmp = do
@@ -1481,7 +1481,7 @@ testEnableCIExpirationOnlyForOneUser tmp = do
       -- new messages are not deleted for second user
       alice #$> ("/_get chat @4 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4"), (1, "alisa 5"), (0, "alisa 6")])
   where
-    cfg = testCfg {initialCleanupManagerDelay = 0, ciExpirationInterval = 500000}
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000}
 
 testDisableCIExpirationOnlyForOneUser :: HasCallStack => FilePath -> IO ()
 testDisableCIExpirationOnlyForOneUser tmp = do
@@ -1539,7 +1539,7 @@ testDisableCIExpirationOnlyForOneUser tmp = do
       -- second user messages are deleted
       alice #$> ("/_get chat @4 count=100", chat, [])
   where
-    cfg = testCfg {initialCleanupManagerDelay = 0, ciExpirationInterval = 500000}
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000}
 
 testUsersTimedMessages :: HasCallStack => FilePath -> IO ()
 testUsersTimedMessages tmp = do

tests/ChatTests/Groups.hs

@@ -9,6 +9,7 @@ import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (concurrently_)
 import Control.Monad (when)
 import qualified Data.Text as T
+import Simplex.Chat.Controller (ChatConfig (..))
 import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
 import Simplex.Chat.Types (GroupMemberRole (..))
 import System.Directory (copyFile)
@@ -420,7 +421,7 @@ testGroup2 =
 
 testGroupDelete :: HasCallStack => FilePath -> IO ()
 testGroupDelete =
-  testChat3 aliceProfile bobProfile cathProfile $
+  testChatCfg3 cfg aliceProfile bobProfile cathProfile $
     \alice bob cath -> do
       createGroup3 "team" alice bob cath
       alice ##> "/d #team"
@@ -444,12 +445,15 @@ testGroupDelete =
       alice <##> bob
       alice <##> cath
       -- unused group contacts are deleted
+      threadDelay 3000000
       bob ##> "@cath hi"
       bob <## "no contact cath"
       (cath </)
       cath ##> "@bob hi"
       cath <## "no contact bob"
       (bob </)
+  where
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
 
 testGroupSameName :: HasCallStack => FilePath -> IO ()
 testGroupSameName =
@@ -1151,7 +1155,7 @@ testUpdateMemberRole =
 
 testGroupDeleteUnusedContacts :: HasCallStack => FilePath -> IO ()
 testGroupDeleteUnusedContacts =
-  testChat3 aliceProfile bobProfile cathProfile $
+  testChatCfg3 cfg aliceProfile bobProfile cathProfile $
     \alice bob cath -> do
       -- create group 1
       createGroup3 "team" alice bob cath
@@ -1210,6 +1214,7 @@ testGroupDeleteUnusedContacts =
       cath `hasContactProfiles` ["alice", "bob", "cath"]
       -- delete group 2, unused contacts and profiles are deleted
       deleteGroup alice bob cath "club"
+      threadDelay 3000000
       bob ##> "/contacts"
       bob <## "alice (Alice)"
       bob `hasContactProfiles` ["alice", "bob"]
@@ -1217,6 +1222,7 @@ testGroupDeleteUnusedContacts =
       cath <## "alice (Alice)"
       cath `hasContactProfiles` ["alice", "cath"]
   where
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
     deleteGroup :: HasCallStack => TestCC -> TestCC -> TestCC -> String -> IO ()
     deleteGroup alice bob cath group = do
       alice ##> ("/d #" <> group)
@@ -1827,7 +1833,7 @@ testGroupLinkIncognitoMembership =
 
 testGroupLinkUnusedHostContactDeleted :: HasCallStack => FilePath -> IO ()
 testGroupLinkUnusedHostContactDeleted =
-  testChat2 aliceProfile bobProfile $
+  testChatCfg2 cfg aliceProfile bobProfile $
     \alice bob -> do
       -- create group 1
       alice ##> "/g team"
@@ -1881,10 +1887,12 @@ testGroupLinkUnusedHostContactDeleted =
       bob `hasContactProfiles` ["alice", "bob"]
       -- delete group 2, unused host contact and profile are deleted
       bobLeaveDeleteGroup alice bob "club"
+      threadDelay 3000000
       bob ##> "/contacts"
       (bob </)
       bob `hasContactProfiles` ["bob"]
   where
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
     bobLeaveDeleteGroup :: HasCallStack => TestCC -> TestCC -> String -> IO ()
     bobLeaveDeleteGroup alice bob group = do
       bob ##> ("/l " <> group)
@@ -1899,7 +1907,7 @@ testGroupLinkUnusedHostContactDeleted =
 
 testGroupLinkIncognitoUnusedHostContactsDeleted :: HasCallStack => FilePath -> IO ()
 testGroupLinkIncognitoUnusedHostContactsDeleted =
-  testChat2 aliceProfile bobProfile $
+  testChatCfg2 cfg aliceProfile bobProfile $
     \alice bob -> do
       bob #$> ("/incognito on", id, "ok")
       bobIncognitoTeam <- createGroupBobIncognito alice bob "team" "alice"
@@ -1912,15 +1920,18 @@ testGroupLinkIncognitoUnusedHostContactsDeleted =
       bob `hasContactProfiles` ["alice", "alice", "bob", T.pack bobIncognitoTeam, T.pack bobIncognitoClub]
       -- delete group 1, unused host contact and profile are deleted
       bobLeaveDeleteGroup alice bob "team" bobIncognitoTeam
+      threadDelay 3000000
       bob ##> "/contacts"
       bob <## "i alice_1 (Alice)"
       bob `hasContactProfiles` ["alice", "bob", T.pack bobIncognitoClub]
       -- delete group 2, unused host contact and profile are deleted
       bobLeaveDeleteGroup alice bob "club" bobIncognitoClub
+      threadDelay 3000000
       bob ##> "/contacts"
       (bob </)
       bob `hasContactProfiles` ["bob"]
   where
+    cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0}
     createGroupBobIncognito :: HasCallStack => TestCC -> TestCC -> String -> String -> IO String
     createGroupBobIncognito alice bob group bobsAliceContact = do
       alice ##> ("/g " <> group)