android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-28 20:29:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

core: delete unused group contacts, don't create new ones (#5590)

Browse source 
* core: delete unused group contacts, don't create new ones

* remove from exceptions

* plans

* fix tests

* remove fixtures

* update plans

* update migration

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
spaced4ndy 2025-01-31 10:32:07 +04:00 • committed by GitHub
parent 7f09de18d9
commit 5d18a49726
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
20 changed files with 416 additions and 1397 deletions
Download patch file Download diff file Expand all files Collapse all files

1
simplex-chat.cabal
View file

@ -222,6 +222,7 @@ library
Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl
Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history
Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions
Simplex.Chat.Store.SQLite.Migrations.M20250129_delete_unused_contacts
other-modules:
Paths_simplex_chat
hs-source-dirs:

1
src/Simplex/Chat/Controller.hs
View file

@ -765,7 +765,6 @@ data ChatResponse
| CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
| CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
| CRGroupLinkDeleted {user :: User, groupInfo :: GroupInfo}
| CRAcceptingGroupJoinRequest {user :: User, groupInfo :: GroupInfo, contact :: Contact}
| CRAcceptingGroupJoinRequestMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRNoMemberContactCreating {user :: User, groupInfo :: GroupInfo, member :: GroupMember} -- only used in CLI
| CRNewMemberContact {user :: User, contact :: Contact, groupInfo :: GroupInfo, member :: GroupMember}

22
src/Simplex/Chat/Library/Commands.hs
View file

@ -1095,26 +1095,7 @@ processChatCommand' vr = \case
withStore' $ \db -> deleteGroupConnectionsAndFiles db user gInfo members
withStore' $ \db -> deleteGroupItemsAndMembers db user gInfo members
withStore' $ \db -> deleteGroup db user gInfo
let contactIds = mapMaybe memberContactId members
(errs1, (errs2, connIds)) <- lift $ second unzip . partitionEithers <$> withStoreBatch (\db -> map (deleteUnusedContact db) contactIds)
let errs = errs1 <> mapMaybe (fmap ChatErrorStore) errs2
unless (null errs) $ toView $ CRChatErrors (Just user) errs
deleteAgentConnectionsAsync user $ concat connIds
pure $ CRGroupDeletedUser user gInfo
where
deleteUnusedContact :: DB.Connection -> ContactId -> IO (Either ChatError (Maybe StoreError, [ConnId]))
deleteUnusedContact db contactId = runExceptT . withExceptT ChatErrorStore $ do
ct <- getContact db vr user contactId
ifM
((directOrUsed ct ||) . isJust <$> liftIO (checkContactHasGroups db user ct))
(pure (Nothing, []))
(getConnections ct)
where
getConnections :: Contact -> ExceptT StoreError IO (Maybe StoreError, [ConnId])
getConnections ct = do
conns <- liftIO $ getContactConnections db vr userId ct
e_ <- (setContactDeleted db user ct $> Nothing) `catchStoreError` (pure . Just)
pure (e_, map aConnId conns)
CTLocal -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of
@ -2986,10 +2967,9 @@ processChatCommand' vr = \case
sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendContactContentMessages user contactId live itemTTL cmrs = do
assertMultiSendable live cmrs
ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId
ct <- withFastStore $ \db -> getContact db vr user contactId
assertDirectAllowed user MDSnd ct XMsgNew_
assertVoiceAllowed ct
unless contactUsed $ withFastStore' $ \db -> updateContactUsed db user ct
processComposedMessages ct
where
assertVoiceAllowed :: Contact -> CM ()

6
src/Simplex/Chat/Library/Internal.hs
View file

@ -797,15 +797,15 @@ acceptContactRequest user@User {userId} UserContactRequest {agentInvitationId =
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
(ct,conn,) <$> withAgent (\a -> acceptContact a (aConnId conn) True invId dm pqSup' subMode)
acceptContactRequestAsync :: User -> UserContactRequest -> Maybe IncognitoProfile -> Bool -> PQSupport -> CM Contact
acceptContactRequestAsync user cReq@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile contactUsed pqSup = do
acceptContactRequestAsync :: User -> UserContactRequest -> Maybe IncognitoProfile -> PQSupport -> CM Contact
acceptContactRequestAsync user cReq@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile pqSup = do
subMode <- chatReadVar subscriptionMode
let profileToSend = profileToSendOnAccept user incognitoProfile False
vr <- chatVersionRange
let chatV = vr `peerConnChatVersion` cReqChatVRange
(cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode pqSup chatV
withStore' $ \db -> do
(ct, Connection {connId}) <- createAcceptedContact db user acId chatV cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile subMode pqSup contactUsed
(ct, Connection {connId}) <- createAcceptedContact db user acId chatV cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile subMode pqSup True
deleteContactRequestRec db user cReq
setCommandConnId db user cmdId connId
pure ct

49
src/Simplex/Chat/Library/Subscriber.hs
View file

@ -584,7 +584,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
lift $ setContactNetworkStatus ct' NSConnected
toView $ CRContactConnected user ct' (fmap fromLocalProfile incognitoProfile)
when (directOrUsed ct') $ do
unless (contactUsed ct') $ withFastStore' $ \db -> updateContactUsed db user ct'
createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ E2EInfo pqEnc) Nothing
createFeatureEnabledItems ct'
when (contactConnInitiated conn') $ do
@ -697,7 +696,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- [async agent commands] XGrpMemIntro continuation on receiving INV
CFCreateConnGrpMemInv
| maxVersion (peerChatVRange conn) >= groupDirectInvVersion -> sendWithoutDirectCReq
| otherwise -> sendWithDirectCReq
| otherwise -> messageError "processGroupMessage INV: member chat version range incompatible"
where
sendWithoutDirectCReq = do
let GroupMember {groupMemberId, memberId} = m
@ -705,13 +704,6 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
liftIO $ setConnConnReqInv db user connId cReq
getHostConnId db user groupId
sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
sendWithDirectCReq = do
let GroupMember {groupMemberId, memberId} = m
contData <- withStore' $ \db -> do
setConnConnReqInv db user connId cReq
getXGrpMemIntroContGroup db user m
forM_ contData $ \(hostConnId, directConnReq) ->
sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
-- [async agent commands] group link auto-accept continuation on receiving INV
CFCreateConnGrpInv -> do
ct <- withStore $ \db -> getContactViaMember db vr user m
@ -1310,9 +1302,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case autoAccept of
Just AutoAccept {acceptIncognito, businessAddress}
| businessAddress ->
if v < groupFastLinkJoinVersion || (isSimplexTeam && v < businessChatsVersion)
if isSimplexTeam && v < businessChatsVersion
then do
ct <- acceptContactRequestAsync user cReq Nothing True reqPQSup
ct <- acceptContactRequestAsync user cReq Nothing reqPQSup
toView $ CRAcceptingContactRequest user ct
else do
gInfo <- acceptBusinessJoinRequestAsync user cReq
@ -1321,7 +1313,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Nothing -> do
-- [incognito] generate profile to send, create connection with incognito profile
incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
ct <- acceptContactRequestAsync user cReq incognitoProfile True reqPQSup
ct <- acceptContactRequestAsync user cReq incognitoProfile reqPQSup
toView $ CRAcceptingContactRequest user ct
Just groupId -> do
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
@ -1331,10 +1323,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
mem <- acceptGroupJoinRequestAsync user gInfo cReq gLinkMemRole profileMode
createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CRAcceptingGroupJoinRequestMember user gInfo mem
else do
-- TODO v5.7 remove old API (or v6.0?)
ct <- acceptContactRequestAsync user cReq profileMode False PQSupportOff
toView $ CRAcceptingGroupJoinRequest user gInfo ct
else messageError "processUserContactRequest: chat version range incompatible for accepting group join request"
_ -> toView $ CRReceivedContactRequest user cReq
memberCanSend :: GroupMember -> CM () -> CM ()
@ -1540,8 +1529,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageError = toView . CRMessageError user "error"
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do
let ExtMsgContent content _ fInv_ _ _ = mcExtMsgContent mc
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
-- case content of
@ -1747,7 +1735,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
ExtMsgContent content mentions fInv_ itemTTL live_ = mcExtMsgContent mc
ts@(_, ft_) = msgContentTexts content
createBlockedByAdmin
| groupFeatureAllowed SGFFullDelete gInfo = do -- ignores member role when blocked by admin
| groupFeatureAllowed SGFFullDelete gInfo = do
-- ignores member role when blocked by admin
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs
groupMsgToView gInfo ci'
@ -2466,8 +2455,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of
XInfo p -> do
let contactUsed = connDirect activeConn
ct <- withStore $ \db -> createDirectContact db user conn' p contactUsed
ct <- withStore $ \db -> createDirectContact db user conn' p
toView $ CRContactConnecting user ct
pure (conn', False)
XGrpLinkInv glInv -> do
@ -2505,17 +2493,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Right _ -> messageError "x.grp.mem.intro ignored: member already exists"
Left _ -> do
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
subMode <- chatReadVar subscriptionMode
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
groupConnIds <- createConn subMode
directConnIds <- case memChatVRange of
Nothing -> Just <$> createConn subMode
case memChatVRange of
Nothing -> messageError "x.grp.mem.intro: member chat version range incompatible"
Just (ChatVersionRange mcvr)
| maxVersion mcvr >= groupDirectInvVersion -> pure Nothing
| otherwise -> Just <$> createConn subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
void $ withStore $ \db -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds directConnIds customUserProfileId subMode
| maxVersion mcvr >= groupDirectInvVersion -> do
subMode <- chatReadVar subscriptionMode
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
groupConnIds <- createConn subMode
let chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
void $ withStore $ \db -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds subMode
| otherwise -> messageError "x.grp.mem.intro: member chat version range incompatible"
_ -> messageError "x.grp.mem.intro can be only sent by host member"
where
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode

14
src/Simplex/Chat/Store/Direct.hs
View file

@ -46,7 +46,6 @@ module Simplex.Chat.Store.Direct
updateContactConnectionAlias,
updatePCCIncognito,
deletePCCIncognitoProfile,
updateContactUsed,
updateContactUnreadChat,
setUserChatsRead,
updateContactStatus,
@ -240,10 +239,10 @@ createIncognitoProfile db User {userId} p = do
createdAt <- getCurrentTime
createIncognitoProfile_ db userId createdAt p
createDirectContact :: DB.Connection -> User -> Connection -> Profile -> Bool -> ExceptT StoreError IO Contact
createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p@Profile {preferences} contactUsed = do
createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p@Profile {preferences} = do
currentTs <- liftIO getCurrentTime
(localDisplayName, contactId, profileId) <- createContact_ db userId p localAlias Nothing currentTs contactUsed
(localDisplayName, contactId, profileId) <- createContact_ db userId p localAlias Nothing currentTs
liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
let profile = toLocalProfile profileId p localAlias
userPreferences = emptyChatPrefs
@ -255,7 +254,7 @@ createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p
profile,
activeConn = Just conn,
viaGroup = Nothing,
contactUsed,
contactUsed = True,
contactStatus = CSActive,
chatSettings = defaultChatSettings,
userPreferences,
@ -471,11 +470,6 @@ deletePCCIncognitoProfile db User {userId} profileId =
|]
(userId, profileId)
updateContactUsed :: DB.Connection -> User -> Contact -> IO ()
updateContactUsed db User {userId} Contact {contactId} = do
updatedAt <- getCurrentTime
DB.execute db "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (updatedAt, userId, contactId)
updateContactUnreadChat :: DB.Connection -> User -> Contact -> Bool -> IO ()
updateContactUnreadChat db User {userId} Contact {contactId} unreadChat = do
updatedAt <- getCurrentTime

55
src/Simplex/Chat/Store/Groups.hs
View file

@ -110,7 +110,6 @@ module Simplex.Chat.Store.Groups
updateGroupMemberSettings,
updateGroupMemberBlocked,
getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup,
getHostConnId,
createMemberContact,
getMemberContact,
@ -1397,33 +1396,23 @@ getForwardInvitedMembers db vr user forwardMember highlyAvailable = do
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> VersionChat -> MemberInfo -> Maybe MemberRestrictions -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> VersionChat -> MemberInfo -> Maybe MemberRestrictions -> (CommandId, ConnId) -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember
db
user@User {userId}
gInfo@GroupInfo {groupId}
gInfo
_host@GroupMember {memberContactId, activeConn}
chatV
memInfo@(MemberInfo _ _ memChatVRange memberProfile)
memRestrictions_
(groupCmdId, groupAgentConnId)
directConnIds
customUserProfileId
subMode = do
let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn
memRestriction = restriction <$> memRestrictions_
currentTs <- liftIO getCurrentTime
newMember <- case directConnIds of
Just (directCmdId, directAgentConnId) -> do
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId ConnNew chatV mcvr memberContactId Nothing customUserProfileId cLevel currentTs subMode PQSupportOff
liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId memberProfile "" (Just groupId) currentTs False
liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, directConnId)
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Just contactId, memProfileId}
Nothing -> do
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs
let newMember = NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
liftIO $ do
member <- createNewMember_ db user gInfo newMember currentTs
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId chatV mcvr memberContactId cLevel currentTs subMode
@ -1850,12 +1839,6 @@ mergeContactRecords db vr user@User {userId} to@Contact {localDisplayName = keep
assertNotUser db user fromCt
liftIO $ do
currentTs <- getCurrentTime
-- next query fixes incorrect unused contacts deletion
when (contactDirect toCt && not (contactUsed toCt)) $
DB.execute
db
"UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?"
(currentTs, userId, toContactId)
DB.execute
db
"UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?"
@ -2061,36 +2044,6 @@ getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do
Just groupConnReq -> Just (hostConnId, XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq})
_ -> Nothing
getXGrpMemIntroContGroup :: DB.Connection -> User -> GroupMember -> IO (Maybe (Int64, ConnReqInvitation))
getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
fmap join . maybeFirstRow toCont $
DB.query
db
[sql|
SELECT ch.connection_id, c.conn_req_inv
FROM group_members m
JOIN contacts ct ON ct.contact_id = m.contact_id
LEFT JOIN connections c ON c.connection_id = (
SELECT MAX(cc.connection_id)
FROM connections cc
WHERE cc.contact_id = ct.contact_id
)
JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group
JOIN group_members mh ON mh.group_id = g.group_id
LEFT JOIN connections ch ON ch.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.user_id = ? AND cc.group_member_id = mh.group_member_id
)
WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0
|]
(userId, userId, groupMemberId, GCHostMember)
where
toCont :: (Int64, Maybe ConnReqInvitation) -> Maybe (Int64, ConnReqInvitation)
toCont (hostConnId, connReq_) = case connReq_ of
Just connReq -> Just (hostConnId, connReq)
_ -> Nothing
getHostConnId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
getHostConnId db user@User {userId} groupId = do
hostMemberId <- getHostMemberId_ db user groupId

3
src/Simplex/Chat/Store/Messages.hs
View file

@ -2562,8 +2562,7 @@ getGroupChatItemIdByText db User {userId, localDisplayName = userName} groupId c
SELECT i.chat_item_id
FROM chat_items i
JOIN group_members m ON m.group_member_id = i.group_member_id
JOIN contacts c ON c.contact_id = m.contact_id
WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ?
WHERE i.user_id = ? AND i.group_id = ? AND m.local_display_name = ? AND i.item_text like ?
ORDER BY i.chat_item_id DESC
LIMIT 1
|]

4
src/Simplex/Chat/Store/SQLite/Migrations.hs
View file

@ -126,6 +126,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20250105_indexes
import Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl
import Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history
import Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions
import Simplex.Chat.Store.SQLite.Migrations.M20250129_delete_unused_contacts
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -251,7 +252,8 @@ schemaMigrations =
("20250105_indexes", m20250105_indexes, Just down_m20250105_indexes),
("20250115_chat_ttl", m20250115_chat_ttl, Just down_m20250115_chat_ttl),
("20250122_chat_items_include_in_history", m20250122_chat_items_include_in_history, Just down_m20250122_chat_items_include_in_history),
("20250126_mentions", m20250126_mentions, Just down_m20250126_mentions)
("20250126_mentions", m20250126_mentions, Just down_m20250126_mentions),
("20250129_delete_unused_contacts", m20250129_delete_unused_contacts, Just down_m20250129_delete_unused_contacts)
]
-- | The list of migrations in ascending order by date

64
src/Simplex/Chat/Store/SQLite/Migrations/M20250129_delete_unused_contacts.hs Normal file
View file

@ -0,0 +1,64 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20250129_delete_unused_contacts where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20250129_delete_unused_contacts :: Query
m20250129_delete_unused_contacts =
[sql|
CREATE TEMPORARY TABLE temp_delete_contacts (
contact_id INTEGER PRIMARY KEY,
contact_profile_id INTEGER NOT NULL,
local_display_name TEXT NOT NULL
);
INSERT INTO temp_delete_contacts(contact_id, contact_profile_id, local_display_name)
SELECT contact_id, contact_profile_id, local_display_name
FROM contacts
WHERE contact_used = 0 AND is_user = 0
AND contact_id NOT IN (SELECT contact_id FROM users)
AND contact_id NOT IN (SELECT contact_id FROM contact_requests);
CREATE TEMPORARY TABLE temp_delete_profiles (contact_profile_id INTEGER PRIMARY KEY);
INSERT OR IGNORE INTO temp_delete_profiles(contact_profile_id)
SELECT custom_user_profile_id FROM connections
WHERE contact_id IN (SELECT contact_id FROM temp_delete_contacts)
AND custom_user_profile_id IS NOT NULL;
UPDATE group_members SET contact_id = NULL
WHERE contact_id IN (SELECT contact_id FROM temp_delete_contacts);
DELETE FROM connections
WHERE contact_id IN (SELECT contact_id FROM temp_delete_contacts);
DELETE FROM contacts
WHERE contact_id IN (SELECT contact_id FROM temp_delete_contacts);
DELETE FROM contact_profiles
WHERE
(contact_profile_id IN (SELECT contact_profile_id FROM temp_delete_profiles)
OR contact_profile_id IN (SELECT contact_profile_id FROM temp_delete_contacts))
AND contact_profile_id NOT IN (SELECT contact_profile_id FROM group_members)
AND contact_profile_id NOT IN (SELECT member_profile_id FROM group_members)
AND contact_profile_id NOT IN (SELECT contact_profile_id FROM contact_requests)
AND contact_profile_id NOT IN (SELECT custom_user_profile_id FROM connections);
DELETE FROM display_names
WHERE local_display_name IN (SELECT local_display_name FROM temp_delete_contacts)
AND local_display_name NOT IN (SELECT local_display_name FROM group_members)
AND local_display_name NOT IN (SELECT local_display_name FROM users)
AND local_display_name NOT IN (SELECT local_display_name FROM groups)
AND local_display_name NOT IN (SELECT local_display_name FROM user_contact_links)
AND local_display_name NOT IN (SELECT local_display_name FROM contact_requests);
DROP TABLE temp_delete_contacts;
DROP TABLE temp_delete_profiles;
|]
down_m20250129_delete_unused_contacts :: Query
down_m20250129_delete_unused_contacts =
[sql|
|]

207
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
View file

@ -646,30 +646,6 @@ Query:
Plan:
Query:
INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id, created_at, updated_at, chat_ts)
SELECT contact_profile_id, group_id, ?, ?, ?, ?, ?
FROM group_members
WHERE group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_tags_chats USING COVERING INDEX idx_chat_tags_chats_chat_tag_id_contact_id (contact_id=?)
SEARCH received_probes USING COVERING INDEX idx_received_probes_contact_id (contact_id=?)
SEARCH sent_probe_hashes USING COVERING INDEX idx_sent_probe_hashes_contact_id (contact_id=?)
SEARCH sent_probes USING COVERING INDEX idx_sent_probes_contact_id (contact_id=?)
SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_contact_id (contact_id=?)
SEARCH calls USING COVERING INDEX idx_calls_contact_id (contact_id=?)
SEARCH chat_items USING COVERING INDEX idx_chat_items_fwd_from_contact_id (fwd_from_contact_id=?)
SEARCH chat_items USING COVERING INDEX idx_chat_items_contact_id (contact_id=?)
SEARCH contact_requests USING COVERING INDEX idx_contact_requests_contact_id (contact_id=?)
SEARCH connections USING COVERING INDEX idx_connections_contact_id (contact_id=?)
SEARCH connections USING COVERING INDEX idx_connections_via_contact (via_contact=?)
SEARCH files USING COVERING INDEX idx_files_contact_id (contact_id=?)
SEARCH group_members USING COVERING INDEX idx_group_members_contact_id (contact_id=?)
SEARCH group_members USING COVERING INDEX idx_group_members_invited_by (invited_by=?)
SEARCH users USING COVERING INDEX sqlite_autoindex_users_1 (contact_id=?)
Query:
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
@ -1145,15 +1121,13 @@ Query:
SELECT i.chat_item_id
FROM chat_items i
JOIN group_members m ON m.group_member_id = i.group_member_id
JOIN contacts c ON c.contact_id = m.contact_id
WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ?
WHERE i.user_id = ? AND i.group_id = ? AND m.local_display_name = ? AND i.item_text like ?
ORDER BY i.chat_item_id DESC
LIMIT 1
Plan:
SEARCH i USING INDEX idx_chat_items_groups_user_mention (user_id=? AND group_id=?)
SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
SEARCH c USING INTEGER PRIMARY KEY (rowid=?)
USE TEMP B-TREE FOR ORDER BY
Query:
@ -1227,14 +1201,6 @@ Query:
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE group_members
SET contact_id = ?, updated_at = ?
WHERE group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE group_members
SET contact_id = ?, updated_at = ?
@ -2787,66 +2753,6 @@ Plan:
SEARCH c USING INDEX idx_connections_updated_at (user_id=?)
SEARCH uc USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT ch.connection_id, c.conn_req_inv
FROM group_members m
JOIN contacts ct ON ct.contact_id = m.contact_id
LEFT JOIN connections c ON c.connection_id = (
SELECT MAX(cc.connection_id)
FROM connections cc
WHERE cc.contact_id = ct.contact_id
)
JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group
JOIN group_members mh ON mh.group_id = g.group_id
LEFT JOIN connections ch ON ch.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.user_id = ? AND cc.group_member_id = mh.group_member_id
)
WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0
Plan:
SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
SEARCH ct USING INTEGER PRIMARY KEY (rowid=?)
SEARCH c USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
CORRELATED SCALAR SUBQUERY 1
SEARCH cc USING COVERING INDEX idx_connections_contact_id (contact_id=?)
SEARCH g USING INTEGER PRIMARY KEY (rowid=?)
SEARCH mh USING INDEX sqlite_autoindex_group_members_1 (group_id=?)
SEARCH ch USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
CORRELATED SCALAR SUBQUERY 2
SEARCH cc USING COVERING INDEX idx_connections_group_member (user_id=? AND group_member_id=?)
Query:
SELECT ch.connection_id, g.group_id, m.group_member_id, m.member_id, c.conn_req_inv
FROM contacts ct
JOIN group_members m ON m.contact_id = ct.contact_id
LEFT JOIN connections c ON c.connection_id = (
SELECT MAX(cc.connection_id)
FROM connections cc
WHERE cc.group_member_id = m.group_member_id
)
JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group
JOIN group_members mh ON mh.group_id = g.group_id
LEFT JOIN connections ch ON ch.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.user_id = ? AND cc.group_member_id = mh.group_member_id
)
WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = 0 AND mh.member_category = ?
Plan:
SEARCH ct USING INTEGER PRIMARY KEY (rowid=?)
SEARCH g USING INTEGER PRIMARY KEY (rowid=?)
SEARCH m USING INDEX sqlite_autoindex_group_members_1 (group_id=?)
SEARCH c USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
CORRELATED SCALAR SUBQUERY 1
SEARCH cc
SEARCH mh USING INDEX sqlite_autoindex_group_members_1 (group_id=?)
SEARCH ch USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
CORRELATED SCALAR SUBQUERY 2
SEARCH cc USING COVERING INDEX idx_connections_group_member (user_id=? AND group_member_id=?)
Query:
SELECT chat_item_id
FROM chat_item_messages
@ -3112,30 +3018,6 @@ Plan:
SEARCH ct USING INDEX idx_contacts_chat_ts (user_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT ct.contact_id
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.contact_status = ? AND ct.deleted = 0 AND ct.is_user = 0
AND p.display_name = ? AND p.full_name = ?
AND p.image = ?
Plan:
SEARCH ct USING INDEX idx_contacts_chat_ts (user_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT ct.contact_id
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.contact_status = ? AND ct.deleted = 0 AND ct.is_user = 0
AND p.display_name = ? AND p.full_name = ?
AND p.image is NULL
Plan:
SEARCH ct USING INDEX idx_contacts_chat_ts (user_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete
FROM xftp_file_descriptions d
@ -3269,18 +3151,6 @@ Plan:
SEARCH m USING INDEX idx_group_members_user_id (user_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT m.member_role, gp.preferences
FROM groups g
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members m USING (group_id)
WHERE g.user_id = ? AND m.contact_id = ?
Plan:
SEARCH m USING INDEX idx_group_members_contact_id (contact_id=?)
SEARCH g USING INTEGER PRIMARY KEY (rowid=?)
SEARCH gp USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.chat_msg_event, pgm.group_member_intro_id
FROM pending_group_messages pgm
@ -3482,22 +3352,6 @@ Query:
Plan:
SEARCH group_member_intros USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE group_members
SET contact_id = ?,
local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = ?),
contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = ?),
updated_at = ?
WHERE contact_id = ?
AND user_id = ?
Plan:
SEARCH group_members USING INDEX idx_group_members_user_id (user_id=?)
SCALAR SUBQUERY 1
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
SCALAR SUBQUERY 2
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE group_members
SET contact_id = ?, local_display_name = ?, contact_profile_id = ?, updated_at = ?
@ -5092,25 +4946,6 @@ Query: DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?
Plan:
SEARCH contact_requests USING INTEGER PRIMARY KEY (rowid=?)
Query: DELETE FROM contacts WHERE contact_id = ? AND user_id = ?
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_tags_chats USING COVERING INDEX idx_chat_tags_chats_chat_tag_id_contact_id (contact_id=?)
SEARCH received_probes USING COVERING INDEX idx_received_probes_contact_id (contact_id=?)
SEARCH sent_probe_hashes USING COVERING INDEX idx_sent_probe_hashes_contact_id (contact_id=?)
SEARCH sent_probes USING COVERING INDEX idx_sent_probes_contact_id (contact_id=?)
SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_contact_id (contact_id=?)
SEARCH calls USING COVERING INDEX idx_calls_contact_id (contact_id=?)
SEARCH chat_items USING COVERING INDEX idx_chat_items_fwd_from_contact_id (fwd_from_contact_id=?)
SEARCH chat_items USING COVERING INDEX idx_chat_items_contact_id (contact_id=?)
SEARCH contact_requests USING COVERING INDEX idx_contact_requests_contact_id (contact_id=?)
SEARCH connections USING COVERING INDEX idx_connections_contact_id (contact_id=?)
SEARCH connections USING COVERING INDEX idx_connections_via_contact (via_contact=?)
SEARCH files USING COVERING INDEX idx_files_contact_id (contact_id=?)
SEARCH group_members USING COVERING INDEX idx_group_members_contact_id (contact_id=?)
SEARCH group_members USING COVERING INDEX idx_group_members_invited_by (invited_by=?)
SEARCH users USING COVERING INDEX sqlite_autoindex_users_1 (contact_id=?)
Query: DELETE FROM contacts WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
@ -5596,10 +5431,6 @@ Query: SELECT group_id FROM group_members WHERE group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query: SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1
Plan:
SEARCH group_members USING INDEX idx_group_members_user_id (user_id=?)
Query: SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1
Plan:
SEARCH groups USING INDEX idx_groups_chat_ts (user_id=?)
@ -5620,10 +5451,6 @@ Query: SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contac
Plan:
SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?)
Query: SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1
Plan:
SEARCH user_contact_links USING INDEX idx_user_contact_links_group_id (group_id=?)
Query: SELECT group_member_id FROM group_members WHERE user_id = ? AND contact_profile_id = ? AND group_member_id != ? LIMIT 1
Plan:
SEARCH group_members USING INDEX idx_group_members_user_id (user_id=?)
@ -5684,10 +5511,6 @@ Query: SELECT xgrplinkmem_received FROM group_members WHERE group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE chat_items SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=?)
Query: UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
@ -5740,10 +5563,6 @@ Query: UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id
Plan:
SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?
Plan:
SEARCH connections USING INDEX idx_connections_contact_id (contact_id=?)
Query: UPDATE connections SET quota_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?
Plan:
SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
@ -5756,10 +5575,6 @@ Query: UPDATE connections SET to_subscribe = 0 WHERE to_subscribe = 1
Plan:
SEARCH connections USING INDEX idx_connections_to_subscribe (to_subscribe=?)
Query: UPDATE connections SET via_contact = ?, updated_at = ? WHERE via_contact = ? AND user_id = ?
Plan:
SEARCH connections USING INDEX idx_connections_via_contact (via_contact=?)
Query: UPDATE contact_requests SET contact_id = ? WHERE user_id = ? AND local_display_name = ?
Plan:
SEARCH contact_requests USING INDEX sqlite_autoindex_contact_requests_1 (user_id=? AND local_display_name=?)
@ -5780,18 +5595,10 @@ Query: UPDATE contacts SET contact_grp_inv_sent = ?, updated_at = ? WHERE contac
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE contacts SET contact_used = ? WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE contacts SET enable_ntfs = ?, send_rcpts = ?, favorite = ? WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH contacts USING INTEGER PRIMARY KEY (rowid=?)
@ -5864,10 +5671,6 @@ Query: UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id
Plan:
SEARCH group_members USING INDEX idx_group_members_user_id (user_id=?)
Query: UPDATE group_members SET invited_by = ?, updated_at = ? WHERE invited_by = ? AND user_id = ?
Plan:
SEARCH group_members USING INDEX idx_group_members_invited_by (invited_by=?)
Query: UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH group_members USING INDEX idx_group_members_user_id (user_id=?)
@ -5884,10 +5687,6 @@ Query: UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_memb
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE group_members SET sent_inv_queue_info = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE group_members SET xgrplinkmem_received = ?, updated_at = ? WHERE group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
@ -5980,10 +5779,6 @@ Query: UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?
Plan:
SEARCH usage_conditions USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?
Plan:
SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE users SET active_user = 0
Plan:
SCAN users

8
src/Simplex/Chat/Store/Shared.hs
View file

@ -381,10 +381,10 @@ setCommandConnId db User {userId} cmdId connId = do
createContact :: DB.Connection -> User -> Profile -> ExceptT StoreError IO ()
createContact db User {userId} profile = do
currentTs <- liftIO getCurrentTime
void $ createContact_ db userId profile "" Nothing currentTs True
void $ createContact_ db userId profile "" Nothing currentTs
createContact_ :: DB.Connection -> UserId -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Bool -> ExceptT StoreError IO (Text, ContactId, ProfileId)
createContact_ db userId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs contactUsed =
createContact_ :: DB.Connection -> UserId -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId)
createContact_ db userId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs =
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
DB.execute
db
@ -394,7 +394,7 @@ createContact_ db userId Profile {displayName, fullName, image, contactLink, pre
DB.execute
db
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts, contact_used) VALUES (?,?,?,?,?,?,?,?)"
(profileId, ldn, userId, viaGroup, currentTs, currentTs, currentTs, BI contactUsed)
(profileId, ldn, userId, viaGroup, currentTs, currentTs, currentTs, BI True)
contactId <- insertedRowId db
pure $ Right (ldn, contactId, profileId)

1
src/Simplex/Chat/View.hs
View file

@ -315,7 +315,6 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRGroupLinkCreated u g cReq mRole -> ttyUser u $ groupLink_ "Group link is created!" g cReq mRole
CRGroupLink u g cReq mRole -> ttyUser u $ groupLink_ "Group link:" g cReq mRole
CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g
CRAcceptingGroupJoinRequest _ g c -> [ttyFullContact c <> ": accepting request to join group " <> ttyGroup' g <> "..."]
CRAcceptingGroupJoinRequestMember _ g m -> [ttyFullMember m <> ": accepting request to join group " <> ttyGroup' g <> "..."]
CRNoMemberContactCreating u g m -> ttyUser u ["member " <> ttyGroup' g <> " " <> ttyMember m <> " does not have direct connection, creating"]
CRNewMemberContact u _ g m -> ttyUser u ["contact for member " <> ttyGroup' g <> " " <> ttyMember m <> " is created"]

157
tests/Bots/DirectoryTests.hs
View file

@ -51,10 +51,10 @@ directoryServiceTests = do
it "should NOT allow approving if roles are incorrect" testNotApprovedBadRoles
describe "should require re-approval if profile is changed by" $ do
it "the registration owner" testRegOwnerChangedProfile
it "another owner" testAnotherOwnerChangedProfile
it "another owner" testAnotherOwnerChangedProfile -- TODO fix - doesn't work if another owner is not connected as contact
describe "should require profile update if group link is removed by " $ do
it "the registration owner" testRegOwnerRemovedLink
it "another owner" testAnotherOwnerRemovedLink
it "another owner" testAnotherOwnerRemovedLink -- TODO fix - doesn't work if another owner is not connected as contact
describe "duplicate groups (same display name and full name)" $ do
it "should ask for confirmation if a duplicate group is submitted" testDuplicateAskConfirmation
it "should prohibit registration if a duplicate group is listed" testDuplicateProhibitRegistration
@ -230,7 +230,7 @@ testSuspendResume ps =
bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!"
groupFound bob "privacy"
superUser #> "@SimpleX-Directory privacy"
groupFoundN_ (Just 1) 2 superUser "privacy"
groupFoundN_ "" (Just 1) 2 superUser "privacy"
superUser #> "@SimpleX-Directory /link 1:privacy"
superUser <# "SimpleX-Directory> > /link 1:privacy"
superUser <## " The link to join the group ID 1 (privacy):"
@ -284,10 +284,10 @@ testSetRole ps =
testJoinGroup :: HasCallStack => TestParams -> IO ()
testJoinGroup ps =
withDirectoryServiceCfg ps testCfgGroupLinkViaContact $ \superUser dsLink ->
withNewTestChatCfg ps testCfgGroupLinkViaContact "bob" bobProfile $ \bob -> do
withNewTestChatCfg ps testCfgGroupLinkViaContact "cath" cathProfile $ \cath ->
withNewTestChatCfg ps testCfgGroupLinkViaContact "dan" danProfile $ \dan -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob -> do
withNewTestChat ps "cath" cathProfile $ \cath ->
withNewTestChat ps "dan" danProfile $ \dan -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
cath `connectVia` dsLink
@ -301,10 +301,10 @@ testJoinGroup ps =
cath <## "2 members"
cath ##> ("/c " <> groupLink)
cath <## "connection request sent!"
cath <## "SimpleX-Directory_1: contact is connected"
cath <## "contact SimpleX-Directory_1 is merged into SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
cath <## "#privacy: joining the group..."
cath <## "#privacy: you joined the group"
cath <## "contact and member are merged: SimpleX-Directory, #privacy SimpleX-Directory_1"
cath <## "use @SimpleX-Directory <message> to send messages"
cath <# ("#privacy SimpleX-Directory> " <> welcomeMsg)
cath <## "#privacy: member bob (Bob) is connected"
bob <## "#privacy: SimpleX-Directory added cath (Catherine) to the group (connecting...)"
@ -316,11 +316,9 @@ testJoinGroup ps =
concurrentlyN_
[ do
bob <## "dan (Daniel): accepting request to join group #privacy..."
bob <## "dan (Daniel): contact is connected"
bob <## "dan invited to group #privacy via your group link"
bob <## "#privacy: dan joined the group",
do
dan <## "bob (Bob): contact is connected"
dan <## "#privacy: joining the group..."
dan <## "#privacy: you joined the group"
dan <# ("#privacy bob> " <> welcomeMsg)
dan
@ -456,9 +454,9 @@ testInviteToOwnersGroup ps =
testDelistedOwnerLeaves :: HasCallStack => TestParams -> IO ()
testDelistedOwnerLeaves ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -468,13 +466,16 @@ testDelistedOwnerLeaves ps =
bob <## ""
bob <## "The group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner left)."
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
groupNotFound cath "privacy"
testDelistedOwnerRemoved :: HasCallStack => TestParams -> IO ()
testDelistedOwnerRemoved ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -483,38 +484,45 @@ testDelistedOwnerRemoved ps =
bob <## ""
bob <## "The group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner is removed)."
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
groupNotFound cath "privacy"
testNotDelistedMemberLeaves :: HasCallStack => TestParams -> IO ()
testNotDelistedMemberLeaves ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
leaveGroup "privacy" cath
bob <## "#privacy: cath left the group"
(superUser </)
groupFound cath "privacy"
cath `connectVia` dsLink
cath #> "@SimpleX-Directory_1 privacy"
groupFoundN_ "_1" Nothing 2 cath "privacy"
testNotDelistedMemberRemoved :: HasCallStack => TestParams -> IO ()
testNotDelistedMemberRemoved ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
removeMember "privacy" bob cath
(superUser </)
groupFound cath "privacy"
cath `connectVia` dsLink
cath #> "@SimpleX-Directory_1 privacy"
groupFoundN_ "_1" Nothing 2 cath "privacy"
testDelistedServiceRemoved :: HasCallStack => TestParams -> IO ()
testDelistedServiceRemoved ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -525,7 +533,8 @@ testDelistedServiceRemoved ps =
bob <## ""
bob <## "The group is no longer listed in the directory."
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (directory service is removed)."
groupNotFound cath "privacy"
cath `connectVia` dsLink
groupNotFound_ "_1" cath "privacy"
testDelistedGroupDeleted :: HasCallStack => TestParams -> IO ()
testDelistedGroupDeleted ps =
@ -553,12 +562,15 @@ testDelistedGroupDeleted ps =
testDelistedRoleChanges :: HasCallStack => TestParams -> IO ()
testDelistedRoleChanges ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
groupFoundN 3 cath "privacy"
-- de-listed if service role changed
bob ##> "/mr privacy SimpleX-Directory member"
@ -599,12 +611,15 @@ testDelistedRoleChanges ps =
testNotDelistedMemberRoleChanged :: HasCallStack => TestParams -> IO ()
testNotDelistedMemberRoleChanged ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
groupFoundN 3 cath "privacy"
bob ##> "/mr privacy cath member"
bob <## "#privacy: you changed the role of cath from owner to member"
@ -663,9 +678,9 @@ testNotApprovedBadRoles ps =
testRegOwnerChangedProfile :: HasCallStack => TestParams -> IO ()
testRegOwnerChangedProfile ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -675,6 +690,9 @@ testRegOwnerChangedProfile ps =
bob <## "It is hidden from the directory until approved."
cath <## "bob updated group #privacy:"
cath <## "full name changed to: Privacy and Security"
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
groupNotFound cath "privacy"
superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated."
reapproveGroup 3 superUser bob
@ -682,12 +700,15 @@ testRegOwnerChangedProfile ps =
testAnotherOwnerChangedProfile :: HasCallStack => TestParams -> IO ()
testAnotherOwnerChangedProfile ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
cath ##> "/gp privacy privacy Privacy and Security"
cath <## "full name changed to: Privacy and Security"
bob <## "cath updated group #privacy:"
@ -701,9 +722,9 @@ testAnotherOwnerChangedProfile ps =
testRegOwnerRemovedLink :: HasCallStack => TestParams -> IO ()
testRegOwnerRemovedLink ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
@ -720,6 +741,9 @@ testRegOwnerRemovedLink ps =
cath <## "description changed to:"
cath <## "Welcome!"
superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed."
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
groupNotFound cath "privacy"
bob ##> ("/set welcome #privacy " <> welcomeWithLink)
bob <## "description changed to:"
@ -734,12 +758,15 @@ testRegOwnerRemovedLink ps =
testAnotherOwnerRemovedLink :: HasCallStack => TestParams -> IO ()
testAnotherOwnerRemovedLink ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
addCathAsOwner bob cath
cath `connectVia` dsLink
cath <## "contact and member are merged: SimpleX-Directory_1, #privacy SimpleX-Directory"
cath <## "use @SimpleX-Directory <message> to send messages"
bob ##> "/show welcome #privacy"
bob <## "Welcome message:"
welcomeWithLink <- getTermLine bob
@ -883,9 +910,9 @@ testDuplicateProhibitApproval ps =
testListUserGroups :: HasCallStack => TestParams -> IO ()
testListUserGroups ps =
withDirectoryServiceCfg ps testCfgCreateGroupDirect $ \superUser dsLink ->
withNewTestChatCfg ps testCfgCreateGroupDirect "bob" bobProfile $ \bob ->
withNewTestChatCfg ps testCfgCreateGroupDirect "cath" cathProfile $ \cath -> do
withDirectoryService ps $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
cath `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
@ -893,7 +920,7 @@ testListUserGroups ps =
fullAddMember "privacy" "Privacy" bob cath GRMember
joinGroup "privacy" cath bob
cath <## "#privacy: member SimpleX-Directory_1 is connected"
cath <## "contact SimpleX-Directory_1 is merged into SimpleX-Directory"
cath <## "contact and member are merged: SimpleX-Directory, #privacy SimpleX-Directory_1"
cath <## "use @SimpleX-Directory <message> to send messages"
registerGroupId superUser bob "security" "Security" 2 2
registerGroupId superUser cath "anonymity" "Anonymity" 3 1
@ -937,7 +964,6 @@ testRestoreDirectory ps = do
groupFound bob "security"
groupFoundN 3 cath "privacy"
cath #> "@SimpleX-Directory security"
cath <## "SimpleX-Directory: quantum resistant end-to-end encryption enabled"
groupFoundN' 2 cath "security"
listGroups :: HasCallStack => TestCC -> TestCC -> TestCC -> IO ()
@ -1161,8 +1187,8 @@ connectVia :: TestCC -> String -> IO ()
u `connectVia` dsLink = do
u ##> ("/c " <> dsLink)
u <## "connection request sent!"
u <## "SimpleX-Directory: contact is connected"
u <# "SimpleX-Directory> Welcome to SimpleX-Directory service!"
u .<## ": contact is connected"
u .<# "> Welcome to SimpleX-Directory service!"
u <## "Send a search string to find groups or /help to learn how to add groups to directory."
u <## ""
u <## "For example, send privacy to find groups about privacy."
@ -1206,19 +1232,22 @@ groupFoundN count u name = do
groupFoundN' count u name
groupFoundN' :: Int -> TestCC -> String -> IO ()
groupFoundN' = groupFoundN_ Nothing
groupFoundN' = groupFoundN_ "" Nothing
groupFoundN_ :: Maybe Int -> Int -> TestCC -> String -> IO ()
groupFoundN_ shownId_ count u name = do
u <# ("SimpleX-Directory> > " <> name)
groupFoundN_ :: String -> Maybe Int -> Int -> TestCC -> String -> IO ()
groupFoundN_ suffix shownId_ count u name = do
u <# ("SimpleX-Directory" <> suffix <> "> > " <> name)
u <## " Found 1 group(s)."
u <#. ("SimpleX-Directory> " <> maybe "" (\gId -> show gId <> ". ") shownId_ <> name)
u <#. ("SimpleX-Directory" <> suffix <> "> " <> maybe "" (\gId -> show gId <> ". ") shownId_ <> name)
u <## "Welcome message:"
u <##. "Link to join the group "
u <## (show count <> " members")
groupNotFound :: TestCC -> String -> IO ()
groupNotFound u s = do
u #> ("@SimpleX-Directory " <> s)
u <# ("SimpleX-Directory> > " <> s)
groupNotFound = groupNotFound_ ""
groupNotFound_ :: String -> TestCC -> String -> IO ()
groupNotFound_ suffix u s = do
u #> ("@SimpleX-Directory" <> suffix <> " " <> s)
u <# ("SimpleX-Directory" <> suffix <> "> > " <> s)
u <## " No groups found"

24
tests/ChatClient.hs
View file

@ -254,30 +254,6 @@ prevVersion (Version v) = Version (v - 1)
nextVersion :: Version v -> Version v
nextVersion (Version v) = Version (v + 1)
testCfgCreateGroupDirect :: ChatConfig
testCfgCreateGroupDirect =
mkCfgCreateGroupDirect testCfg
mkCfgCreateGroupDirect :: ChatConfig -> ChatConfig
mkCfgCreateGroupDirect cfg =
cfg
{ chatVRange = groupCreateDirectVRange,
agentConfig = testAgentCfgSlow
}
groupCreateDirectVRange :: VersionRangeChat
groupCreateDirectVRange = mkVersionRange (VersionChat 1) (VersionChat 1)
testCfgGroupLinkViaContact :: ChatConfig
testCfgGroupLinkViaContact =
mkCfgGroupLinkViaContact testCfg
mkCfgGroupLinkViaContact :: ChatConfig -> ChatConfig
mkCfgGroupLinkViaContact cfg = cfg {chatVRange = groupLinkViaContactVRange}
groupLinkViaContactVRange :: VersionRangeChat
groupLinkViaContactVRange = mkVersionRange (VersionChat 1) (VersionChat 2)
createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
createTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix profile = do
Right db@ChatDatabase {chatStore, agentStore} <- createDatabase ps coreOptions dbPrefix

39
tests/ChatTests/Direct.hs
View file

@ -60,7 +60,6 @@ chatDirectTests = do
it "deleting contact deletes profile" testDeleteContactDeletesProfile
it "delete contact keeping conversation" testDeleteContactKeepConversation
it "delete conversation keeping contact" testDeleteConversationKeepContact
it "unused contact is deleted silently" testDeleteUnusedContactSilent
it "direct message quoted replies" testDirectMessageQuotedReply
it "direct message update" testDirectMessageUpdate
it "direct message edit history" testDirectMessageEditHistory
@ -612,42 +611,6 @@ testDeleteConversationKeepContact =
alice @@@ [("@bob", "hi")]
alice <##> bob
testDeleteUnusedContactSilent :: HasCallStack => TestParams -> IO ()
testDeleteUnusedContactSilent =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
bob ##> "/contacts"
bob <### ["alice (Alice)", "cath (Catherine)"]
bob `hasContactProfiles` ["bob", "alice", "cath"]
cath ##> "/contacts"
cath <### ["alice (Alice)", "bob (Bob)"]
cath `hasContactProfiles` ["cath", "alice", "bob"]
-- bob deletes cath, cath's bob contact is deleted silently
bob ##> "/d cath"
bob <## "cath: contact is deleted"
bob ##> "/contacts"
bob <## "alice (Alice)"
threadDelay 50000
cath ##> "/contacts"
cath <## "alice (Alice)"
-- group messages work
alice #> "#team hello"
concurrentlyN_
[ bob <# "#team alice> hello",
cath <# "#team alice> hello"
]
bob #> "#team hi there"
concurrentlyN_
[ alice <# "#team bob> hi there",
cath <# "#team bob> hi there"
]
cath #> "#team hey"
concurrentlyN_
[ alice <# "#team cath> hey",
bob <# "#team cath> hey"
]
testDirectMessageQuotedReply :: HasCallStack => TestParams -> IO ()
testDirectMessageQuotedReply =
testChat2 aliceProfile bobProfile $
@ -2567,7 +2530,7 @@ testSetChatItemTTL =
testSetDirectChatTTL :: HasCallStack => TestParams -> IO ()
testSetDirectChatTTL =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
connectUsers alice bob
connectUsers alice cath

1101
tests/ChatTests/Groups.hs
View file

File diff suppressed because it is too large Load diff

41
tests/ChatTests/Profiles.hs
View file

@ -104,9 +104,11 @@ chatProfileTests = do
testUpdateProfile :: HasCallStack => TestParams -> IO ()
testUpdateProfile =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
connectUsers alice bob
connectUsers alice cath
connectUsers bob cath
alice ##> "/p"
alice <## "user profile: alice (Alice)"
alice <## "use /p <display name> to change it"
@ -1451,7 +1453,7 @@ testSetResetSetConnectionIncognito = testChat2 aliceProfile bobProfile $
testJoinGroupIncognito :: HasCallStack => TestParams -> IO ()
testJoinGroupIncognito =
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
-- non incognito connections
connectUsers alice bob
@ -1526,13 +1528,13 @@ testJoinGroupIncognito =
dan
<### [ ConsoleString $ "#secret_club: member " <> cathIncognito <> " is connected",
"#secret_club: member bob_1 (Bob) is connected",
"contact bob_1 is merged into bob",
"contact and member are merged: bob, #secret_club bob_1",
"use @bob <message> to send messages"
],
do
bob <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
bob <## "#secret_club: new member dan_1 is connected"
bob <## "contact dan_1 is merged into dan"
bob <## "contact and member are merged: dan, #secret_club dan_1"
bob <## "use @dan <message> to send messages",
do
cath <## "#secret_club: alice added dan_1 (Daniel) to the group (connecting...)"
@ -1563,17 +1565,7 @@ testJoinGroupIncognito =
bob <# "#secret_club dan> how is it going?",
cath ?<# "#secret_club dan_1> how is it going?"
]
-- cath and bob can send messages via new direct connection, cath is incognito
bob #> ("@" <> cathIncognito <> " hi, I'm bob")
cath ?<# "bob_1> hi, I'm bob"
cath ?#> "@bob_1 hey, I'm incognito"
bob <# (cathIncognito <> "> hey, I'm incognito")
-- cath and dan can send messages via new direct connection, cath is incognito
dan #> ("@" <> cathIncognito <> " hi, I'm dan")
cath ?<# "dan_1> hi, I'm dan"
cath ?#> "@dan_1 hey, I'm incognito"
dan <# (cathIncognito <> "> hey, I'm incognito")
-- non incognito connections are separate
-- non incognito direct connections are separate
bob <##> cath
dan <##> cath
-- list groups
@ -1632,11 +1624,6 @@ testJoinGroupIncognito =
]
cath ##> "#secret_club hello"
cath <## "you are no longer a member of the group"
-- cath can still message members directly
bob #> ("@" <> cathIncognito <> " I removed you from group")
cath ?<# "bob_1> I removed you from group"
cath ?#> "@bob_1 ok"
bob <# (cathIncognito <> "> ok")
testCantInviteContactIncognito :: HasCallStack => TestParams -> IO ()
testCantInviteContactIncognito = testChat2 aliceProfile bobProfile $
@ -2205,7 +2192,7 @@ testAllowFullDeletionGroup =
testProhibitDirectMessages :: HasCallStack => TestParams -> IO ()
testProhibitDirectMessages =
testChatCfg4 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile danProfile $
testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
@ -2221,7 +2208,7 @@ testProhibitDirectMessages =
alice #> "@cath hello again"
cath <# "alice> hello again"
bob ##> "@cath hello again"
bob <## "direct messages to indirect contact cath are prohibited"
bob <## "bad chat command: direct messages not allowed"
(cath </)
connectUsers cath dan
addMember "team" cath dan GRMember
@ -2242,14 +2229,14 @@ testProhibitDirectMessages =
bob <## "#team: new member dan is connected"
]
alice ##> "@dan hi"
alice <## "direct messages to indirect contact dan are prohibited"
alice <## "bad chat command: direct messages not allowed"
bob ##> "@dan hi"
bob <## "direct messages to indirect contact dan are prohibited"
bob <## "bad chat command: direct messages not allowed"
(dan </)
dan ##> "@alice hi"
dan <## "direct messages to indirect contact alice are prohibited"
dan <## "bad chat command: direct messages not allowed"
dan ##> "@bob hi"
dan <## "direct messages to indirect contact bob are prohibited"
dan <## "bad chat command: direct messages not allowed"
dan #> "@cath hi"
cath <# "dan> hi"
cath #> "@dan hi"

7
tests/ChatTests/Utils.hs
View file

@ -361,6 +361,13 @@ cc <#. line = do
unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
prefix `shouldBe` True
(.<#) :: HasCallStack => TestCC -> String -> Expectation
cc .<# line = do
l <- dropTime <$> getTermLine cc
let suffix = line `isSuffixOf` l
unless suffix $ print ("expected to end with: " <> line, ", got: " <> l)
suffix `shouldBe` True
(<##..) :: HasCallStack => TestCC -> [String] -> Expectation
cc <##.. ls = do
l <- getTermLine cc

9
tests/SchemaDump.hs
View file

@ -103,7 +103,8 @@ testSchemaMigrations = withTmpFiles $ do
schema <- getSchema testDB testSchema
Migrations.run st True $ MTRUp [m]
schema' <- getSchema testDB testSchema
schema' `shouldNotBe` schema
unless (name m `elem` skipComparisonForUpMigrations) $
schema' `shouldNotBe` schema
Migrations.run st True $ MTRDown [downMigr]
unless (name m `elem` skipComparisonForDownMigrations) $ do
schema'' <- getSchema testDB testSchema
@ -112,6 +113,12 @@ testSchemaMigrations = withTmpFiles $ do
schema''' <- getSchema testDB testSchema
schema''' `shouldBe` schema'
skipComparisonForUpMigrations :: [String]
skipComparisonForUpMigrations =
[ -- schema doesn't change
"20250129_delete_unused_contacts"
]
skipComparisonForDownMigrations :: [String]
skipComparisonForDownMigrations =
[ -- on down migration msg_delivery_events table moves down to the end of the file