From 3bf8361911154f87470e43f80b013cb0aaa4d0a0 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Thu, 13 Oct 2022 17:12:22 +0400 Subject: [PATCH] core: group links (#1194) --- docs/rfcs/2022-10-10-group-links.md | 53 ++++ simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 130 +++++++--- src/Simplex/Chat/Controller.hs | 21 ++ .../M20221011_user_contact_links_group_id.hs | 14 ++ src/Simplex/Chat/Migrations/chat_schema.sql | 4 + src/Simplex/Chat/Store.hs | 181 +++++++++---- src/Simplex/Chat/Types.hs | 6 +- src/Simplex/Chat/View.hs | 30 +++ tests/ChatTests.hs | 237 ++++++++++++++++++ tests/MobileTests.hs | 8 + 11 files changed, 603 insertions(+), 82 deletions(-) create mode 100644 docs/rfcs/2022-10-10-group-links.md create mode 100644 src/Simplex/Chat/Migrations/M20221011_user_contact_links_group_id.hs diff --git a/docs/rfcs/2022-10-10-group-links.md b/docs/rfcs/2022-10-10-group-links.md new file mode 100644 index 0000000000..3a3df7d196 --- /dev/null +++ b/docs/rfcs/2022-10-10-group-links.md @@ -0,0 +1,53 @@ +# Group links + +## Problem + +Friction in group discovery and invitation/joining. Currently each group member has to be invited manually, and has first to be connected to an existing group member, even if group is considered as open/public by its owners. + +## Solution + +Allow to create group link(s) - a group link is a new type of contact address link, with enabled auto accept. After receiving and automatically accepting a group join request via such link, a contact is automatically invited to group. This allows to publish such link on a site or another platform and reduce friction required to join a "public" group. + +## Design considerations + +Add group link metadata to contact link? + +- It can be used to display information about the group on the link web page, e.g. a group profile or its part, though it introduces a privacy concern. +- Can be used to display only the fact that it's a group invitation link. +- If we use a separate contact address for each group link, and we don't do auto-join on receiving group invitation corresponding to the group link, group link metadata in contact link is not necessary. + +Use group link metadata when accepting / joining? + +- When accepting we can use the fact that this contact request link is tied to a specific group to automatically invite to group, it's not necessary to parse out this part in agent. +- When joining it could be parsed out in agent and communicated to chat for chat to know it has to automatically accept the corresponding group invite that should follow. Alternatively we can ignore this metadata in agent/chat and let the user to accept incoming group invitation manually. The advantages of the second approach are that it's simpler and that the user can inspect received group profile before accepting. The disadvantage is more friction, though it's on joining side, not on the inviting side (join is performed only once). + +Allow each group member who can invite to create their own link, or have such link be a part of group's profile, so it can be created by owners? + +- The advantage of the second approach is that owners can set up an always online client, so the connectivity in group would be better compared to one that could be provided by regular clients. Another advantage is that link can be shared by any member role, even without permission to invite members. +- The disadvantage is that if group has no owners, the link can no longer be created. Also since all member would be using the same link for sharing, it would become a group identifier signalling they're members of the same group. +- There're probably other advantages/disadvantages to be considered. Other considerations: + - Group owners can overwrite each others links. + - When member leaves group or is removed from group, he should remove corresponding contact address to avoid accepting respective contact requests. + - When member role is changed, link/contact address should be conditionally removed if new role doesn't allow adding members. + +Allow to create a link with incognito membership? + +- Even though we currently don't allow to add members for incognito memberships to avoid incognito / non incognito profiles confusion, when accepting group join requests via group links, same incognito profile that is used for membership could be shared. +- Take into account the plan to allow configuring auto-accept on regular contact requests so that accepting is always incognito, regardless of incognito mode. For group links it has to be yet another specific mode of auto accept so that the same profile is re-used instead of usual per request incognito profile. + +## Implementation + +``` +ALTER TABLE user_contact_links ADD COLUMN group_id INTEGER REFERENCES groups ON DELETE CASCADE; +``` + +API: + +- APICreateGroupLink GroupId +- APIDeleteGroupLink GroupId +- APIShowGroupLink GroupId +- CreateGroupLink GroupName -- for terminal +- DeleteGroupLink GroupName -- for terminal +- ShowGroupLink GroupName -- for terminal +- CRGroupLinkCreated ConnReqContact -- response on create +- CRGroupLink ConnReqContact -- response on show diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 1cbfa4739e..63ab7ce9c8 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -54,6 +54,7 @@ library Simplex.Chat.Migrations.M20221001_shared_msg_id_indices Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id + Simplex.Chat.Migrations.M20221011_user_contact_links_group_id Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.ProfileGenerator diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index d6837ffd25..15b622b94f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -485,6 +485,7 @@ processChatCommand = \case withChatLock . procCmd $ do forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel + deleteGroupLink' user gInfo `catchError` \_ -> pure () forM_ members $ deleteMemberConnection user -- functions below are called in separate transactions to prevent crashes on android -- (possibly, race condition on integrity check?) @@ -522,7 +523,11 @@ processChatCommand = \case CTContactRequest -> pure $ chatCmdError "not supported" APIAcceptContact connReqId -> withUser $ \user@User {userId} -> withChatLock $ do cReq <- withStore $ \db -> getContactRequest db userId connReqId - procCmd $ CRAcceptingContactRequest <$> acceptContactRequest user cReq + -- [incognito] generate profile to send, create connection with incognito profile + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + ct <- acceptContactRequest user cReq incognitoProfile + pure $ CRAcceptingContactRequest ct APIRejectContact connReqId -> withUser $ \User {userId} -> withChatLock $ do cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- withStore $ \db -> @@ -737,15 +742,15 @@ processChatCommand = \case withStore $ \db -> createUserContactLink db userId connId cReq pure $ CRUserContactLinkCreated cReq DeleteMyAddress -> withUser $ \user -> withChatLock $ do - conns <- withStore (`getUserContactLinkConnections` user) + conns <- withStore (`getUserAddressConnections` user) procCmd $ do forM_ conns $ \conn -> deleteAgentConnectionAsync user conn `catchError` \_ -> pure () - withStore' (`deleteUserContactLink` user) + withStore' (`deleteUserAddress` user) pure CRUserContactLinkDeleted ShowMyAddress -> withUser $ \User {userId} -> - uncurry3 CRUserContactLink <$> withStore (`getUserContactLink` userId) + uncurry3 CRUserContactLink <$> withStore (`getUserAddress` userId) AddressAutoAccept onOff msgContent -> withUser $ \User {userId} -> do - uncurry3 CRUserContactLinkUpdated <$> withStore (\db -> updateUserContactLinkAutoAccept db userId onOff msgContent) + uncurry3 CRUserContactLinkUpdated <$> withStore (\db -> updateUserAddressAutoAccept db userId onOff msgContent) AcceptContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIAcceptContact connReqId @@ -885,6 +890,7 @@ processChatCommand = \case ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) Nothing Nothing toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci -- TODO delete direct connections that were unused + deleteGroupLink' user gInfo `catchError` \_ -> pure () forM_ members $ deleteMemberConnection user withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft pure $ CRLeftMemberUser gInfo {membership = membership {memberStatus = GSMemLeft}} @@ -929,6 +935,30 @@ processChatCommand = \case UpdateGroupProfile gName profile -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIUpdateGroupProfile groupId profile + APICreateGroupLink groupId -> withUser $ \user -> withChatLock $ do + gInfo@GroupInfo {membership = membership@GroupMember {memberRole = userRole}} <- withStore $ \db -> getGroupInfo db user groupId + when (userRole < GRAdmin) $ throwChatError CEGroupUserRole + when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined gInfo) + unless (memberActive membership) $ throwChatError CEGroupMemberNotActive + (connId, cReq) <- withAgent $ \a -> createConnection a True SCMContact + withStore $ \db -> createGroupLink db user gInfo connId cReq + pure $ CRGroupLinkCreated gInfo cReq + APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock $ do + gInfo <- withStore $ \db -> getGroupInfo db user groupId + deleteGroupLink' user gInfo + pure $ CRGroupLinkDeleted gInfo + APIGetGroupLink groupId -> withUser $ \user -> do + gInfo <- withStore $ \db -> getGroupInfo db user groupId + CRGroupLink gInfo <$> withStore (\db -> getGroupLink db user gInfo) + CreateGroupLink gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APICreateGroupLink groupId + DeleteGroupLink gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIDeleteGroupLink groupId + ShowGroupLink gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIGetGroupLink groupId SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName (safeDecodeUtf8 quotedMsg) @@ -1108,15 +1138,16 @@ processChatCommand = \case groupId <- getGroupIdByName db user gName groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName pure (groupId, groupMemberId) - sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> m () - sendGrpInvitation user ct@Contact {localDisplayName} GroupInfo {groupId, groupProfile, membership} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do - let GroupMember {memberRole = userRole, memberId = userMemberId} = membership - groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile - msg <- sendDirectContactMessage ct $ XGrpInv groupInv - let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole - ci <- saveSndChatItem user (CDDirectSnd ct) msg content Nothing Nothing - toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci - setActive $ ActiveG localDisplayName + +sendGrpInvitation :: ChatMonad m => User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> m () +sendGrpInvitation user ct@Contact {localDisplayName} GroupInfo {groupId, groupProfile, membership} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do + let GroupMember {memberRole = userRole, memberId = userMemberId} = membership + groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile + msg <- sendDirectContactMessage ct $ XGrpInv groupInv + let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole + ci <- saveSndChatItem user (CDDirectSnd ct) msg content Nothing Nothing + toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci + setActive $ ActiveG localDisplayName setExpireCIs :: (MonadUnliftIO m, MonadReader ChatController m) => Bool -> m () setExpireCIs b = do @@ -1266,15 +1297,19 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F f = filePath `combine` (name <> suffix <> ext) in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) -acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> m Contact -acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} = do - -- [incognito] generate profile to send, create connection with incognito profile - incognito <- readTVarIO =<< asks incognitoMode - incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing +acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe Profile -> m Contact +acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile = do let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile + -- TODO acceptContactAsync connId <- withAgent $ \a -> acceptContact a True invId . directMessage $ XInfo profileToSend withStore' $ \db -> createAcceptedContact db userId connId cName profileId p userContactLinkId xContactId incognitoProfile +deleteGroupLink' :: ChatMonad m => User -> GroupInfo -> m () +deleteGroupLink' user gInfo = do + conn <- withStore $ \db -> getGroupLinkConnection db user gInfo + deleteAgentConnectionAsync user conn `catchError` \_ -> pure () + withStore' $ \db -> deleteGroupLink db user gInfo + agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () agentSubscriber = do q <- asks $ subQ . smpAgent @@ -1340,10 +1375,7 @@ subscribeUserConnections agentBatchSubscribe user = do contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> m () contactSubsToView rs = toView . CRContactSubSummary . map (uncurry ContactSubStatus) . resultsFor rs contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> m () - contactLinkSubsToView rs ucs = case resultsFor rs ucs of - [] -> pure () - ((_, Just e) : _) -> toView $ CRUserContactLinkSubError e - _ -> toView CRUserContactLinkSubscribed + contactLinkSubsToView rs = toView . CRUserContactSubSummary . map (uncurry UserContactSubStatus) . resultsFor rs groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m () groupSubsToView rs gs ms ce = do mapM_ groupSub $ @@ -1581,12 +1613,21 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM toView $ CRContactConnected ct (fmap fromLocalProfile incognitoProfile) setActive $ ActiveC c showToast (c <> "> ") "connected" - forM_ viaUserContactLink $ \userContactLinkId -> do + forM_ viaUserContactLink $ \userContactLinkId -> withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case - Just (_, True, Just mc) -> do - msg <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing)) - ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing - toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci + Just (_, True, mc_, groupId_) -> do + forM_ mc_ $ \mc -> do + msg <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing)) + ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing + toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci + forM_ groupId_ $ \groupId -> do + gInfo <- withStore $ \db -> getGroupInfo db user groupId + gVar <- asks idsDrg + -- TODO async and continuation? + (grpAgentConnId, cReq) <- withAgent $ \a -> createConnection a True SCMInvitation + member <- withStore $ \db -> createNewContactMember db gVar user groupId ct GRMember grpAgentConnId cReq + sendGrpInvitation user ct gInfo member cReq + toView $ CRSentGroupInvitation gInfo ct member _ -> pure () Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) -> do when (maybe False ((== ConnReady) . connStatus) activeConn) $ do @@ -1864,12 +1905,26 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM withStore (\db -> createOrUpdateContactRequest db userId userContactLinkId invId p xContactId_) >>= \case CORContact contact -> toView $ CRContactRequestAlreadyAccepted contact CORRequest cReq@UserContactRequest {localDisplayName} -> do - (_, autoAccept, _) <- withStore $ \db -> getUserContactLink db userId - if autoAccept - then acceptContactRequest user cReq >>= toView . CRAcceptingContactRequest - else do - toView $ CRReceivedContactRequest cReq - showToast (localDisplayName <> "> ") "wants to connect to you" + withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case + Just (_, autoAccept, _, groupId_) -> + if autoAccept + then case groupId_ of + Nothing -> do + -- [incognito] generate profile to send, create connection with incognito profile + -- TODO allow to configure incognito setting on auto accept instead of checking incognito mode + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + ct <- acceptContactRequest user cReq incognitoProfile + toView $ CRAcceptingContactRequest ct + Just groupId -> do + gInfo@GroupInfo {membership} <- withStore $ \db -> getGroupInfo db user groupId + let incognitoProfile = if memberIncognito membership then Just . fromLocalProfile $ memberProfile membership else Nothing + ct <- acceptContactRequest user cReq incognitoProfile + toView $ CRAcceptingGroupJoinRequest gInfo ct + else do + toView $ CRReceivedContactRequest cReq + showToast (localDisplayName <> "> ") "wants to connect to you" + _ -> pure () withCompletedCommand :: Connection -> ACommand 'Agent -> (CommandData -> m ()) -> m () withCompletedCommand Connection {connId} agentMsg action = do @@ -2406,6 +2461,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM members <- withStore' $ \db -> getGroupMembers db user gInfo if memberId (membership :: GroupMember) == memId then checkRole membership $ do + deleteGroupLink' user gInfo `catchError` \_ -> pure () forM_ members $ deleteMemberConnection user deleteMember membership RGEUserDeleted toView $ CRDeletedMemberUser gInfo {membership = membership {memberStatus = GSMemRemoved}} m @@ -2914,6 +2970,12 @@ chatCommandP = ("/groups" <|> "/gs") $> ListGroups, "/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP), ("/group_profile #" <|> "/gp #" <|> "/group_profile " <|> "/gp ") *> (UpdateGroupProfile <$> displayName <* A.space <*> groupProfile), + "/_create link #" *> (APICreateGroupLink <$> A.decimal), + "/_delete link #" *> (APIDeleteGroupLink <$> A.decimal), + "/_get link #" *> (APIGetGroupLink <$> A.decimal), + "/create link #" *> (CreateGroupLink <$> displayName), + "/delete link #" *> (DeleteGroupLink <$> displayName), + "/show link #" *> (ShowGroupLink <$> displayName), (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> A.takeByteString), (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* optional (A.char '@') <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> A.takeByteString), ("/contacts" <|> "/cs") $> ListContacts, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index ee1fd84670..bb96523705 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -161,6 +161,9 @@ data ChatCommand | APILeaveGroup GroupId | APIListMembers GroupId | APIUpdateGroupProfile GroupId GroupProfile + | APICreateGroupLink GroupId + | APIDeleteGroupLink GroupId + | APIGetGroupLink GroupId | GetUserSMPServers | SetUserSMPServers [SMPServer] | APISetChatItemTTL (Maybe Int64) @@ -203,6 +206,9 @@ data ChatCommand | ListMembers GroupName | ListGroups | UpdateGroupProfile GroupName GroupProfile + | CreateGroupLink GroupName + | DeleteGroupLink GroupName + | ShowGroupLink GroupName | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: ByteString, message :: ByteString} | LastMessages (Maybe ChatName) Int | SendFile ChatName FilePath @@ -295,6 +301,7 @@ data ChatResponse | CRContactsSubscribed {server :: SMPServer, contactRefs :: [ContactRef]} | CRContactSubError {contact :: Contact, chatError :: ChatError} | CRContactSubSummary {contactSubscriptions :: [ContactSubStatus]} + | CRUserContactSubSummary {userContactSubscriptions :: [UserContactSubStatus]} | CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRGroupInvitation {groupInfo :: GroupInfo} @@ -312,6 +319,10 @@ data ChatResponse | CRGroupRemoved {groupInfo :: GroupInfo} | CRGroupDeleted {groupInfo :: GroupInfo, member :: GroupMember} | CRGroupUpdated {fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} + | CRGroupLinkCreated {groupInfo :: GroupInfo, connReqContact :: ConnReqContact} + | CRGroupLink {groupInfo :: GroupInfo, connReqContact :: ConnReqContact} + | CRGroupLinkDeleted {groupInfo :: GroupInfo} + | CRAcceptingGroupJoinRequest {groupInfo :: GroupInfo, contact :: Contact} | CRMemberSubError {groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError} | CRMemberSubSummary {memberSubscriptions :: [MemberSubStatus]} | CRGroupSubscribed {groupInfo :: GroupInfo} @@ -379,6 +390,16 @@ instance ToJSON MemberSubStatus where toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +data UserContactSubStatus = UserContactSubStatus + { userContact :: UserContact, + userContactError :: Maybe ChatError + } + deriving (Show, Generic) + +instance ToJSON UserContactSubStatus where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + data PendingSubStatus = PendingSubStatus { connection :: PendingContactConnection, connError :: Maybe ChatError diff --git a/src/Simplex/Chat/Migrations/M20221011_user_contact_links_group_id.hs b/src/Simplex/Chat/Migrations/M20221011_user_contact_links_group_id.hs new file mode 100644 index 0000000000..4ad6fcb8dc --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20221011_user_contact_links_group_id.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20221011_user_contact_links_group_id where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20221011_user_contact_links_group_id :: Query +m20221011_user_contact_links_group_id = + [sql| +ALTER TABLE user_contact_links ADD COLUMN group_id INTEGER REFERENCES groups ON DELETE CASCADE; + +CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links(group_id); +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index ba9366b586..8145c20183 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -259,6 +259,7 @@ CREATE TABLE user_contact_links( updated_at TEXT CHECK(updated_at NOT NULL), auto_accept INTEGER DEFAULT 0, auto_reply_msg_content TEXT DEFAULT NULL, + group_id INTEGER REFERENCES groups ON DELETE CASCADE, UNIQUE(user_id, local_display_name) ); CREATE TABLE contact_requests( @@ -427,3 +428,6 @@ CREATE UNIQUE INDEX idx_chat_items_group_shared_msg_id ON chat_items( shared_msg_id ); CREATE INDEX idx_msg_deliveries_message_id ON msg_deliveries(message_id); +CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links( + group_id +); diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index d88c5740d2..74c403965f 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -43,12 +43,16 @@ module Simplex.Chat.Store updateContactConnectionAlias, getUserContacts, createUserContactLink, - getUserContactLinkConnections, + getUserAddressConnections, getUserContactLinks, - deleteUserContactLink, - getUserContactLink, + deleteUserAddress, + getUserAddress, getUserContactLinkById, - updateUserContactLinkAutoAccept, + updateUserAddressAutoAccept, + createGroupLink, + getGroupLinkConnection, + deleteGroupLink, + getGroupLink, createOrUpdateContactRequest, getContactRequest, getContactRequestIdByName, @@ -265,6 +269,7 @@ import Simplex.Chat.Migrations.M20220928_settings import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id +import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..)) @@ -304,7 +309,8 @@ schemaMigrations = ("20220928_settings", m20220928_settings), ("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices), ("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items), - ("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id) + ("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id), + ("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id) ] -- | The list of migrations in ascending order by date @@ -683,33 +689,45 @@ createUserContactLink db userId agentConnId cReq = userContactLinkId <- insertedRowId db void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs -getUserContactLinkConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] -getUserContactLinkConnections db user = do - cs <- liftIO $ getUserContactLinks db user - if null cs then throwError SEUserContactLinkNotFound else pure $ map fst cs +getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] +getUserAddressConnections db User {userId} = do + cs <- liftIO getUserAddressConnections_ + if null cs then throwError SEUserContactLinkNotFound else pure cs + where + getUserAddressConnections_ :: IO [Connection] + getUserAddressConnections_ = + map toConnection + <$> DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL + |] + (userId, userId) getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] getUserContactLinks db User {userId} = - map toResult - <$> DB.queryNamed + map toUserContactConnection + <$> DB.query db [sql| SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, - uc.user_contact_link_id, uc.conn_req_contact + uc.user_contact_link_id, uc.conn_req_contact, uc.group_id FROM connections c JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = :user_id - AND uc.user_id = :user_id - AND uc.local_display_name = '' + WHERE c.user_id = ? AND uc.user_id = ? |] - [":user_id" := userId] + (userId, userId) where - toResult :: (ConnectionRow :. (Int64, ConnReqContact)) -> (Connection, UserContact) - toResult (connRow :. (userContactLinkId, connReqContact)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact}) + toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact) + toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId}) -deleteUserContactLink :: DB.Connection -> User -> IO () -deleteUserContactLink db User {userId} = do +deleteUserAddress :: DB.Connection -> User -> IO () +deleteUserAddress db User {userId} = do DB.execute db [sql| @@ -717,7 +735,7 @@ deleteUserContactLink db User {userId} = do SELECT connection_id FROM connections c JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.local_display_name = '' + WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL ) |] (Only userId) @@ -730,8 +748,7 @@ deleteUserContactLink db User {userId} = do SELECT cr.local_display_name FROM contact_requests cr JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = :user_id - AND uc.local_display_name = '' + WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL ) |] [":user_id" := userId] @@ -743,57 +760,124 @@ deleteUserContactLink db User {userId} = do SELECT cr.contact_profile_id FROM contact_requests cr JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = :user_id - AND uc.local_display_name = '' + WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL ) |] [":user_id" := userId] - DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = ''" (Only userId) + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId) -getUserContactLink :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent) -getUserContactLink db userId = +getUserAddress :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent) +getUserAddress db userId = ExceptT . firstRow id SEUserContactLinkNotFound $ DB.query db [sql| SELECT conn_req_contact, auto_accept, auto_reply_msg_content FROM user_contact_links - WHERE user_id = ? - AND local_display_name = '' + WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL |] (Only userId) -getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (ConnReqContact, Bool, Maybe MsgContent)) +getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (ConnReqContact, Bool, Maybe MsgContent, Maybe GroupId)) getUserContactLinkById db userId userContactLinkId = maybeFirstRow id $ DB.query db [sql| - SELECT conn_req_contact, auto_accept, auto_reply_msg_content + SELECT conn_req_contact, auto_accept, auto_reply_msg_content, group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? |] (userId, userContactLinkId) -updateUserContactLinkAutoAccept :: DB.Connection -> UserId -> Bool -> Maybe MsgContent -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent) -updateUserContactLinkAutoAccept db userId autoAccept msgContent = do - (cReqUri, _, _) <- getUserContactLink db userId - liftIO updateUserContactLinkAutoAccept_ +updateUserAddressAutoAccept :: DB.Connection -> UserId -> Bool -> Maybe MsgContent -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent) +updateUserAddressAutoAccept db userId autoAccept msgContent = do + (cReqUri, _, _) <- getUserAddress db userId + liftIO updateUserAddressAutoAccept_ pure (cReqUri, autoAccept, msgContent) where - updateUserContactLinkAutoAccept_ :: IO () - updateUserContactLinkAutoAccept_ = + updateUserAddressAutoAccept_ :: IO () + updateUserAddressAutoAccept_ = DB.execute db [sql| UPDATE user_contact_links SET auto_accept = ?, auto_reply_msg_content = ? - WHERE user_id = ? - AND local_display_name = '' + WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL |] (autoAccept, msgContent, userId) +createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> ExceptT StoreError IO () +createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq = + checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO user_contact_links (user_id, group_id, local_display_name, conn_req_contact, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (userId, groupId, "group_link_" <> localDisplayName, cReq, True, currentTs, currentTs) + groupLinkId <- insertedRowId db + void $ createConnection_ db userId ConnUserContact (Just groupLinkId) agentConnId Nothing Nothing Nothing 0 currentTs + +getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection +getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} = + ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $ + DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ? + |] + (userId, userId, groupId) + +deleteGroupLink :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroupLink db User {userId} GroupInfo {groupId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, groupId) + DB.execute + db + [sql| + DELETE FROM display_names + WHERE user_id = ? + AND local_display_name in ( + SELECT cr.local_display_name + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, userId, groupId) + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT cr.contact_profile_id + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, groupId) + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) + +getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO ConnReqContact +getGroupLink db User {userId} gInfo@GroupInfo {groupId} = + ExceptT . firstRow fromOnly (SEGroupLinkNotFound gInfo) $ + DB.query db "SELECT conn_req_contact FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) + createOrUpdateContactRequest :: DB.Connection -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayName, fullName, image} xContactId_ = liftIO (maybeM getContact' xContactId_) >>= \case @@ -1307,14 +1391,14 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do <$> DB.query db [sql| - SELECT conn_req_contact + SELECT conn_req_contact, group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? |] (userId, userContactLinkId) where - userContact_ :: [Only ConnReqContact] -> Either StoreError UserContact - userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq} + userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact + userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId} userContact_ _ = Left SEUserContactLinkNotFound getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection @@ -2947,11 +3031,12 @@ getContactRequestChatPreviews_ db User {userId} = cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, cr.xcontact_id, cr.created_at, cr.updated_at FROM contact_requests cr - JOIN connections c USING (user_contact_link_id) - JOIN contact_profiles p USING (contact_profile_id) - WHERE cr.user_id = ? + JOIN connections c ON c.user_contact_link_id = cr.user_contact_link_id + JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id + JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id + WHERE cr.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL |] - (Only userId) + (userId, userId) where toContactRequestChatPreview :: ContactRequestRow -> AChat toContactRequestChatPreview cReqRow = @@ -4240,6 +4325,8 @@ data StoreError | SEChatItemNotFoundByFileId {fileId :: FileTransferId} | SEChatItemNotFoundByGroupId {groupId :: GroupId} | SEProfileNotFound {profileId :: Int64} + | SEDuplicateGroupLink {groupInfo :: GroupInfo} + | SEGroupLinkNotFound {groupInfo :: GroupInfo} deriving (Show, Exception, Generic) instance ToJSON StoreError where diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 8d635ac34f..6539943480 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -110,10 +110,14 @@ instance ToJSON ContactRef where toEncoding = J.genericToEncoding J.defaultOptio data UserContact = UserContact { userContactLinkId :: Int64, - connReqContact :: ConnReqContact + connReqContact :: ConnReqContact, + groupId :: Maybe GroupId } deriving (Eq, Show, Generic) +userContactGroupId :: UserContact -> Maybe GroupId +userContactGroupId UserContact {groupId} = groupId + instance ToJSON UserContact where toJSON = J.genericToJSON J.defaultOptions toEncoding = J.genericToEncoding J.defaultOptions diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4393f2a714..bf1099f771 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -141,6 +141,13 @@ responseToView testView = \case [sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors" where (errors, subscribed) = partition (isJust . contactError) summary + CRUserContactSubSummary summary -> + map addressSS addresses + <> ([sShow (length groupLinksSubscribed) <> " group links active" | not (null groupLinksSubscribed)] <> viewErrorsSummary groupLinkErrors " group link errors") + where + (addresses, groupLinks) = partition (\UserContactSubStatus {userContact} -> isNothing . userContactGroupId $ userContact) summary + addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError + (groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks CRGroupInvitation g -> [groupInvitation' g] CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role CRUserJoinedGroup g _ -> viewUserJoinedGroup g @@ -158,6 +165,10 @@ responseToView testView = \case CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"] CRGroupDeleted g m -> [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"] CRGroupUpdated g g' m -> viewGroupUpdated g g' m + CRGroupLinkCreated g cReq -> groupLink_ "Group link is created!" g cReq + CRGroupLink g cReq -> groupLink_ "Group link:" g cReq + CRGroupLinkDeleted g -> viewGroupLinkDeleted g + CRAcceptingGroupJoinRequest g c -> [ttyFullContact c <> ": accepting request to join group " <> ttyGroup' g <> "..."] CRMemberSubError g m e -> [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e] CRMemberSubSummary summary -> viewErrorsSummary (filter (isJust . memberError) summary) " group member errors" CRGroupSubscribed g -> viewGroupSubscribed g @@ -424,6 +435,23 @@ autoAcceptStatus_ autoAccept autoReply = ("auto_accept " <> if autoAccept then "on" else "off") : maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply +groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> [StyledString] +groupLink_ intro g cReq = + [ intro, + "", + (plain . strEncode) cReq, + "", + "Anybody can connect to you and join group with: " <> highlight' "/c ", + "to show it again: " <> highlight ("/show link #" <> groupName' g), + "to delete it: " <> highlight ("/delete link #" <> groupName' g) <> " (joined members will remain connected to you)" + ] + +viewGroupLinkDeleted :: GroupInfo -> [StyledString] +viewGroupLinkDeleted g = + [ "Group link is deleted - joined members will remain connected.", + "To create a new group link use " <> highlight ("/create link #" <> groupName' g) + ] + viewSentInvitation :: Maybe Profile -> Bool -> [StyledString] viewSentInvitation incognitoProfile testView = case incognitoProfile of @@ -988,6 +1016,8 @@ viewChatError = \case SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file SEConnectionNotFound _ -> [] -- TODO mutes delete group error, but also mutes any error from getConnectionEntity SEQuotedChatItemNotFound -> ["message not found - reply is not sent"] + SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> groupName' g)] + SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> groupName' g)] e -> ["chat db error: " <> sShow e] ChatErrorDatabase err -> case err of DBErrorEncrypted -> ["error: chat database is already encrypted"] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 7002bf4cba..71d1ede1ec 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -125,6 +125,9 @@ chatTests = do it "mute/unmute group" testMuteGroup describe "chat item expiration" $ do it "set chat item TTL" testSetChatItemTTL + describe "group links" $ do + it "create group link, join via group link" testGroupLink + it "create group link, join via group link - incognito membership" testGroupLinkIncognitoMembership versionTestMatrix2 :: (TestCC -> TestCC -> IO ()) -> Spec versionTestMatrix2 runTest = do @@ -3039,6 +3042,229 @@ testSetChatItemTTL = alice #$> ("/ttl none", id, "ok") alice #$> ("/ttl", id, "old messages are not being deleted") +testGroupLink :: IO () +testGroupLink = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + alice ##> "/g team" + alice <## "group #team is created" + alice <## "use /a team to add members" + alice ##> "/show link #team" + alice <## "no group link, to create: /create link #team" + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" True + alice ##> "/show link #team" + _ <- getGroupLink alice "team" False + alice ##> "/create link #team" + alice <## "you already have link for this group, to show: /show link #team" + bob ##> ("/c " <> gLink) + bob <## "connection request sent!" + alice <## "bob (Bob): accepting request to join group #team..." + concurrentlyN_ + [ do + alice <## "bob (Bob): contact is connected" + alice <## "invitation to join the group #team sent to bob", + do + bob <## "alice (Alice): contact is connected" + bob <## "#team: alice invites you to join the group as member" + bob <## "use /j team to accept" + ] + alice <##> bob + bob ##> "/j team" + concurrently_ + (alice <## "#team: bob joined the group") + (bob <## "#team: you joined the group") + + -- user address doesn't interfere + alice ##> "/ad" + cLink <- getContactLink alice True + cath ##> ("/c " <> cLink) + alice <#? cath + alice ##> "/ac cath" + alice <## "cath (Catherine): accepting contact request..." + concurrently_ + (cath <## "alice (Alice): contact is connected") + (alice <## "cath (Catherine): contact is connected") + alice <##> cath + + -- third member + cath ##> ("/c " <> gLink) + cath <## "connection request sent!" + alice <## "cath_1 (Catherine): accepting request to join group #team..." + concurrentlyN_ + [ do + alice <## "cath_1 (Catherine): contact is connected" + alice <## "invitation to join the group #team sent to cath_1", + do + cath <## "alice_1 (Alice): contact is connected" + cath <## "#team: alice_1 invites you to join the group as member" + cath <## "use /j team to accept" + ] + cath ##> "/j team" + concurrentlyN_ + [ alice <## "#team: cath_1 joined the group", + do + cath <## "#team: you joined the group" + cath <## "#team: member bob (Bob) is connected", + do + bob <## "#team: alice added cath (Catherine) to the group (connecting...)" + bob <## "#team: new member cath is connected" + ] + alice #> "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath <# "#team alice_1> hello") + bob #> "#team hi there" + concurrently_ + (alice <# "#team bob> hi there") + (cath <# "#team bob> hi there") + cath #> "#team hey team" + concurrently_ + (alice <# "#team cath_1> hey team") + (bob <# "#team cath> hey team") + + -- leaving team removes link + alice ##> "/l team" + concurrentlyN_ + [ do + alice <## "#team: you left the group" + alice <## "use /d #team to delete the group", + bob <## "#team: alice left the group", + cath <## "#team: alice_1 left the group" + ] + alice ##> "/show link #team" + alice <## "no group link, to create: /create link #team" + +testGroupLinkIncognitoMembership :: IO () +testGroupLinkIncognitoMembership = + testChat4 aliceProfile bobProfile cathProfile danProfile $ + \alice bob cath dan -> do + -- bob connected incognito to alice + alice ##> "/c" + inv <- getInvitation alice + bob #$> ("/incognito on", id, "ok") + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + bobIncognito <- getTermLine bob + concurrentlyN_ + [ do + bob <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## "use /info alice to print out this incognito profile again", + alice <## (bobIncognito <> ": contact is connected") + ] + bob #$> ("/incognito off", id, "ok") + -- alice creates group + alice ##> "/g team" + alice <## "group #team is created" + alice <## "use /a team to add members" + -- alice invites bob + alice ##> ("/a team " <> bobIncognito) + concurrentlyN_ + [ alice <## ("invitation to join the group #team sent to " <> bobIncognito), + do + bob <## "#team: alice invites you to join the group as admin" + bob <## ("use /j team to join incognito as " <> bobIncognito) + ] + bob ##> "/j team" + concurrently_ + (alice <## ("#team: " <> bobIncognito <> " joined the group")) + (bob <## ("#team: you joined the group incognito as " <> bobIncognito)) + -- bob creates group link, cath joins + bob ##> "/create link #team" + gLink <- getGroupLink bob "team" True + cath ##> ("/c " <> gLink) + cath <## "connection request sent!" + bob <## "cath (Catherine): accepting request to join group #team..." + _ <- getTermLine bob + concurrentlyN_ + [ do + bob <## ("cath (Catherine): contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## "use /info cath to print out this incognito profile again" + bob <## "invitation to join the group #team sent to cath", + do + cath <## (bobIncognito <> ": contact is connected") + cath <## ("#team: " <> bobIncognito <> " invites you to join the group as member") + cath <## "use /j team to accept" + ] + bob ?#> "@cath hi, I'm incognito" + cath <# (bobIncognito <> "> hi, I'm incognito") + cath #> ("@" <> bobIncognito <> " hey, I'm cath") + bob ?<# "cath> hey, I'm cath" + cath ##> "/j team" + concurrentlyN_ + [ bob <## "#team: cath joined the group", + do + cath <## "#team: you joined the group" + cath <## "#team: member alice (Alice) is connected", + do + alice <## ("#team: " <> bobIncognito <> " added cath (Catherine) to the group (connecting...)") + alice <## "#team: new member cath is connected" + ] + -- dan joins incognito + dan #$> ("/incognito on", id, "ok") + dan ##> ("/c " <> gLink) + danIncognito <- getTermLine dan + dan <## "connection request sent incognito!" + bob <## (danIncognito <> ": accepting request to join group #team...") + _ <- getTermLine bob + _ <- getTermLine dan + concurrentlyN_ + [ do + bob <## (danIncognito <> ": contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## ("use /info " <> danIncognito <> " to print out this incognito profile again") + bob <## ("invitation to join the group #team sent to " <> danIncognito), + do + dan <## (bobIncognito <> ": contact is connected, your incognito profile for this contact is " <> danIncognito) + dan <## ("use /info " <> bobIncognito <> " to print out this incognito profile again") + dan <## ("#team: " <> bobIncognito <> " invites you to join the group as member") + dan <## ("use /j team to join incognito as " <> danIncognito) + ] + dan #$> ("/incognito off", id, "ok") + bob ?#> ("@" <> danIncognito <> " hi, I'm incognito") + dan ?<# (bobIncognito <> "> hi, I'm incognito") + dan ?#> ("@" <> bobIncognito <> " hey, me too") + bob ?<# (danIncognito <> "> hey, me too") + dan ##> "/j team" + concurrentlyN_ + [ bob <## ("#team: " <> danIncognito <> " joined the group"), + do + dan <## ("#team: you joined the group incognito as " <> danIncognito) + dan + <### [ "#team: member alice (Alice) is connected", + "#team: member cath (Catherine) is connected" + ], + do + alice <## ("#team: " <> bobIncognito <> " added " <> danIncognito <> " to the group (connecting...)") + alice <## ("#team: new member " <> danIncognito <> " is connected"), + do + cath <## ("#team: " <> bobIncognito <> " added " <> danIncognito <> " to the group (connecting...)") + cath <## ("#team: new member " <> danIncognito <> " is connected") + ] + alice #> "#team hello" + concurrentlyN_ + [ bob ?<# "#team alice> hello", + cath <# "#team alice> hello", + dan ?<# "#team alice> hello" + ] + bob ?#> "#team hi there" + concurrentlyN_ + [ alice <# ("#team " <> bobIncognito <> "> hi there"), + cath <# ("#team " <> bobIncognito <> "> hi there"), + dan ?<# ("#team " <> bobIncognito <> "> hi there") + ] + cath #> "#team hey" + concurrentlyN_ + [ alice <# "#team cath> hey", + bob ?<# "#team cath> hey", + dan ?<# "#team cath> hey" + ] + dan ?#> "#team how is it going?" + concurrentlyN_ + [ alice <# ("#team " <> danIncognito <> "> how is it going?"), + bob ?<# ("#team " <> danIncognito <> "> how is it going?"), + cath <# ("#team " <> danIncognito <> "> how is it going?") + ] + withTestChatContactConnected :: String -> (TestCC -> IO a) -> IO a withTestChatContactConnected dbPrefix action = withTestChat dbPrefix $ \cc -> do @@ -3289,3 +3515,14 @@ getContactLink cc created = do cc <## "to show it again: /sa" cc <## "to delete it: /da (accepted contacts will remain connected)" pure link + +getGroupLink :: TestCC -> String -> Bool -> IO String +getGroupLink cc gName created = do + cc <## if created then "Group link is created!" else "Group link:" + cc <## "" + link <- getTermLine cc + cc <## "" + cc <## "Anybody can connect to you and join group with: /c " + cc <## ("to show it again: /show link #" <> gName) + cc <## ("to delete it: /delete link #" <> gName <> " (joined members will remain connected to you)") + pure link diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 31f3557bcd..43bdfa2d9b 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -57,6 +57,13 @@ memberSubSummary = "{\"resp\":{\"memberSubSummary\":{\"memberSubscriptions\":[]} memberSubSummary = "{\"resp\":{\"type\":\"memberSubSummary\",\"memberSubscriptions\":[]}}" #endif +userContactSubSummary :: String +#if defined(darwin_HOST_OS) && defined(swiftJSON) +userContactSubSummary = "{\"resp\":{\"userContactSubSummary\":{\"userContactSubscriptions\":[]}}}" +#else +userContactSubSummary = "{\"resp\":{\"type\":\"userContactSubSummary\",\"userContactSubscriptions\":[]}}" +#endif + pendingSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) pendingSubSummary = "{\"resp\":{\"pendingSubSummary\":{\"pendingSubscriptions\":[]}}}" @@ -93,6 +100,7 @@ testChatApi = withTmpFiles $ do chatSendCmd cc "/u alice Alice" `shouldReturn` activeUserExists chatSendCmd cc "/_start" `shouldReturn` chatStarted chatRecvMsg cc `shouldReturn` contactSubSummary + chatRecvMsg cc `shouldReturn` userContactSubSummary chatRecvMsg cc `shouldReturn` memberSubSummary chatRecvMsgWait cc 10000 `shouldReturn` pendingSubSummary chatRecvMsgWait cc 10000 `shouldReturn` ""