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>
This commit is contained in:
spaced4ndy
GitHub
parent
d4f9429fc1
commit
425c7b947f
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
22
src/Simplex/Chat/Migrations/M20230608_deleted_contacts.hs
Normal file
22
src/Simplex/Chat/Migrations/M20230608_deleted_contacts.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user