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>
2026-08-28 11:54:07 +00:00 · 2023-06-12 13:45:39 +04:00
parent d4f9429fc1
commit 425c7b947f
8 changed files with 109 additions and 35 deletions
@@ -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
@@ -112,6 +112,7 @@ data ChatConfig = ChatConfig
    testView :: Bool,
    initialCleanupManagerDelay :: Int64,
    cleanupManagerInterval :: NominalDiffTime,
+    cleanupManagerStepDelay :: Int64,
    ciExpirationInterval :: Int64 -- microseconds
  }

@@ -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;
+|]
@@ -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
+);
@@ -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