From 425c7b947fd5a2377341bf925f9283d14857adaa Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 12 Jun 2023 13:45:39 +0400 Subject: [PATCH] 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 | 1 + src/Simplex/Chat.hs | 28 ++++++--- src/Simplex/Chat/Controller.hs | 1 + .../Migrations/M20230608_deleted_contacts.hs | 22 +++++++ src/Simplex/Chat/Migrations/chat_schema.sql | 4 ++ src/Simplex/Chat/Store.hs | 61 +++++++++++++------ tests/ChatTests/Direct.hs | 8 +-- tests/ChatTests/Groups.hs | 19 ++++-- 8 files changed, 109 insertions(+), 35 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20230608_deleted_contacts.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c101f69fd..14c565152 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 23de863b8..b983c1926 100644 --- a/src/Simplex/Chat.hs +++ b/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) - liftIO $ threadDelay' delay + initialDelay <- asks (initialCleanupManagerDelay . config) + 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 + forM_ us $ cleanupUser interval stepDelay + 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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index ce152fe0f..951ddb773 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -112,6 +112,7 @@ data ChatConfig = ChatConfig testView :: Bool, initialCleanupManagerDelay :: Int64, cleanupManagerInterval :: NominalDiffTime, + cleanupManagerStepDelay :: Int64, ciExpirationInterval :: Int64 -- microseconds } diff --git a/src/Simplex/Chat/Migrations/M20230608_deleted_contacts.hs b/src/Simplex/Chat/Migrations/M20230608_deleted_contacts.hs new file mode 100644 index 000000000..b7193300d --- /dev/null +++ b/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; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 04d4c4cd7..95f22cef3 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/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 +); diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index a1d605e71..dd5e05d51 100644 --- a/src/Simplex/Chat/Store.hs +++ b/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 diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 63ad8ca59..3d03f54b3 100644 --- a/tests/ChatTests/Direct.hs +++ b/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 diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 305f1620c..85b9c720b 100644 --- a/tests/ChatTests/Groups.hs +++ b/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 "@bob hi" cath <## "no contact bob" (bob 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 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 TestCC -> TestCC -> String -> String -> IO String createGroupBobIncognito alice bob group bobsAliceContact = do alice ##> ("/g " <> group)