From c684c6f495c5f2872b0913e9d2784db73fe6bc73 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 27 Feb 2025 12:09:43 +0000 Subject: [PATCH] core: member acceptance --- simplex-chat.cabal | 2 ++ src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/Library/Commands.hs | 6 ++++- src/Simplex/Chat/Library/Internal.hs | 2 ++ src/Simplex/Chat/Library/Subscriber.hs | 14 ++++++----- src/Simplex/Chat/Protocol.hs | 7 ++++++ src/Simplex/Chat/Store/Profiles.hs | 28 ++++++++++++++++----- src/Simplex/Chat/Store/SQLite/Migrations.hs | 4 ++- src/Simplex/Chat/Types.hs | 7 ++++++ src/Simplex/Chat/Types/Shared.hs | 23 +++++++++++++++++ 10 files changed, 80 insertions(+), 14 deletions(-) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 3f12ebd1af..ee688a1c2c 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -95,6 +95,7 @@ library Simplex.Chat.Options.Postgres Simplex.Chat.Store.Postgres.Migrations Simplex.Chat.Store.Postgres.Migrations.M20241220_initial + -- Simplex.Chat.Store.Postgres.Migrations.M20250227_member_acceptance else exposed-modules: Simplex.Chat.Archive @@ -224,6 +225,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions Simplex.Chat.Store.SQLite.Migrations.M20250129_delete_unused_contacts Simplex.Chat.Store.SQLite.Migrations.M20250130_indexes + Simplex.Chat.Store.SQLite.Migrations.M20250227_member_acceptance other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e64553af98..a86dffaa7e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -366,6 +366,7 @@ data ChatCommand | ApiGetConnNtfMessages {connIds :: NonEmpty AgentConnId} | APIAddMember GroupId ContactId GroupMemberRole | APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter} + | APIAcceptMember GroupId GroupMemberId GroupMemberRole | APIMemberRole GroupId GroupMemberId GroupMemberRole | APIBlockMemberForAll GroupId GroupMemberId Bool | APIRemoveMember GroupId GroupMemberId diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 624f6a6dc1..9905869210 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1127,7 +1127,7 @@ processChatCommand' vr = \case (user@User {userId}, cReq) <- withFastStore $ \db -> getContactRequest' db connReqId (ct, conn@Connection {connId}, sqSecured) <- acceptContactRequest user cReq incognito ucl <- withFastStore $ \db -> getUserContactLinkById db userId userContactLinkId - let contactUsed = (\(_, groupId_, _) -> isNothing groupId_) ucl + let contactUsed = (\(_, gLinkInfo_) -> isNothing gLinkInfo_) ucl ct' <- withStore' $ \db -> do deleteContactRequestRec db user cReq updateContactAccepted db user ct contactUsed @@ -2023,6 +2023,10 @@ processChatCommand' vr = \case updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CRChatError (Just user)) pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing Nothing -> throwChatError $ CEContactNotActive ct + APIAcceptMember groupId gmId memRole -> withUser $ \user -> do + -- Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId + -- pure $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} -- GSMemApproved? + ok user APIMemberRole groupId memberId memRole -> withUser $ \user -> do Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId if memberId == groupMemberId' membership diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 4a62c4ccb6..37fc95e1ee 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -841,6 +841,7 @@ acceptGroupJoinRequestAsync fromMemberName = displayName, invitedMember = MemberIdRole memberId gLinkMemRole, groupProfile, + acceptance = Nothing, -- TODO [knocking] business = businessChat, groupSize = Just currentMemCount } @@ -900,6 +901,7 @@ acceptBusinessJoinRequestAsync fromMemberName = displayName, invitedMember = MemberIdRole memberId GRMember, groupProfile = businessGroupProfile userProfile groupPreferences, + acceptance = Nothing, -- TODO [knocking] -- This refers to the "title member" that defines the group name and profile. -- This coincides with fromMember to be current user when accepting the connecting user, -- but it will be different when inviting somebody else. diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 44ad4ccc85..c831e7c0fa 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -592,9 +592,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' $ \db -> resetContactConnInitiated db user conn' forM_ viaUserContactLink $ \userContactLinkId -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl + let (UserContactLink {autoAccept}, gli_) = ucl when (connChatVersion < batchSend2Version) $ sendAutoReply ct' autoAccept - forM_ groupId_ $ \groupId -> do + forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole, acceptance = _acceptance} -> do -- TODO groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId subMode <- chatReadVar subscriptionMode groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode @@ -658,7 +658,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRContactSndReady user ct forM_ viaUserContactLink $ \userContactLinkId -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {autoAccept}, _, _) = ucl + let (UserContactLink {autoAccept}, _) = ucl when (connChatVersion >= batchSend2Version) $ sendAutoReply ct autoAccept QCONT -> void $ continueSending connEntity conn @@ -782,6 +782,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings case memberCategory m of GCHostMember -> do + -- TODO [knocking] here it will communicate whether user is approved as member as status of membership toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} let cd = CDGroupRcv gInfo m createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing @@ -793,6 +794,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion GCInviteeMember -> do memberConnectedChatItem gInfo m + -- TODO [knocking] here it will communicate whether member needs to be approved as member status toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} let Connection {viaUserContactLink} = conn when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem @@ -1300,7 +1302,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo CORRequest cReq -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {connReqContact, autoAccept}, groupId_, gLinkMemRole) = ucl + let (UserContactLink {connReqContact, autoAccept}, gLinkInfo_) = ucl isSimplexTeam = sameConnReqContact connReqContact adminContactReq v = maxVersion chatVRange case autoAccept of @@ -1313,13 +1315,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else do gInfo <- acceptBusinessJoinRequestAsync user cReq toView $ CRAcceptingBusinessRequest user gInfo - | otherwise -> case groupId_ of + | otherwise -> case gLinkInfo_ of 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 reqPQSup toView $ CRAcceptingContactRequest user ct - Just groupId -> do + Just GroupLinkInfo {groupId, memberRole = gLinkMemRole, acceptance = _acceptance} -> do gInfo <- withStore $ \db -> getGroupInfo db vr user groupId cfg <- asks config case rejectionReason cfg of diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 94e08a0897..320d984e32 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -331,6 +331,7 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json XGrpAcpt :: MemberId -> ChatMsgEvent 'Json XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json + XGrpLinkAcpt :: MemberId -> ChatMsgEvent 'Json XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json XGrpLinkMem :: Profile -> ChatMsgEvent 'Json XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json @@ -821,6 +822,7 @@ data CMEventTag (e :: MsgEncoding) where XGrpInv_ :: CMEventTag 'Json XGrpAcpt_ :: CMEventTag 'Json XGrpLinkInv_ :: CMEventTag 'Json + XGrpLinkAcpt_ :: CMEventTag 'Json XGrpLinkReject_ :: CMEventTag 'Json XGrpLinkMem_ :: CMEventTag 'Json XGrpMemNew_ :: CMEventTag 'Json @@ -873,6 +875,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where XGrpInv_ -> "x.grp.inv" XGrpAcpt_ -> "x.grp.acpt" XGrpLinkInv_ -> "x.grp.link.inv" + XGrpLinkAcpt_ -> "x.grp.link.acpt" XGrpLinkReject_ -> "x.grp.link.reject" XGrpLinkMem_ -> "x.grp.link.mem" XGrpMemNew_ -> "x.grp.mem.new" @@ -926,6 +929,7 @@ instance StrEncoding ACMEventTag where "x.grp.inv" -> XGrpInv_ "x.grp.acpt" -> XGrpAcpt_ "x.grp.link.inv" -> XGrpLinkInv_ + "x.grp.link.acpt" -> XGrpLinkAcpt_ "x.grp.link.reject" -> XGrpLinkReject_ "x.grp.link.mem" -> XGrpLinkMem_ "x.grp.mem.new" -> XGrpMemNew_ @@ -975,6 +979,7 @@ toCMEventTag msg = case msg of XGrpInv _ -> XGrpInv_ XGrpAcpt _ -> XGrpAcpt_ XGrpLinkInv _ -> XGrpLinkInv_ + XGrpLinkAcpt _ -> XGrpLinkAcpt_ XGrpLinkReject _ -> XGrpLinkReject_ XGrpLinkMem _ -> XGrpLinkMem_ XGrpMemNew _ -> XGrpMemNew_ @@ -1077,6 +1082,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpInv_ -> XGrpInv <$> p "groupInvitation" XGrpAcpt_ -> XGrpAcpt <$> p "memberId" XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation" + XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "memberId" XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection" XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" @@ -1140,6 +1146,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XGrpInv groupInv -> o ["groupInvitation" .= groupInv] XGrpAcpt memId -> o ["memberId" .= memId] XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv] + XGrpLinkAcpt memId -> o ["memberId" .= memId] XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct] XGrpLinkMem profile -> o ["profile" .= profile] XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index a8d1c094d4..b1e5bf59d7 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -18,6 +18,7 @@ module Simplex.Chat.Store.Profiles ( AutoAccept (..), UserMsgReceiptSettings (..), UserContactLink (..), + GroupLinkInfo (..), createUserRecord, createUserRecordAt, getUsersInfo, @@ -77,7 +78,10 @@ where import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) @@ -100,15 +104,15 @@ import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..)) import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId) import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow) -import Simplex.Messaging.Agent.Store.DB (BoolInt (..)) +import Simplex.Messaging.Agent.Store.DB (BoolInt (..), FromField (..), ToField (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode) import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) +import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) #if defined(dbPostgres) import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) @@ -453,6 +457,13 @@ data UserContactLink = UserContactLink } deriving (Show) +data GroupLinkInfo = GroupLinkInfo + { groupId :: GroupId, + acceptance :: GroupAcceptance, + memberRole :: GroupMemberRole + } + deriving (Show) + data AutoAccept = AutoAccept { businessAddress :: Bool, -- possibly, it can be wrapped together with acceptIncognito, or AutoAccept made sum type acceptIncognito :: IncognitoEnabled, @@ -481,18 +492,23 @@ getUserAddress db User {userId} = |] (Only userId) -getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupId, GroupMemberRole) +getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo) getUserContactLinkById db userId userContactLinkId = - ExceptT . firstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) SEUserContactLinkNotFound $ + ExceptT . firstRow (\(ucl :. gli) -> (toUserContactLink ucl, toGroupLinkInfo gli)) SEUserContactLinkNotFound $ DB.query db [sql| - SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role + SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role, group_link_auto_accept FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? |] (userId, userContactLinkId) + where + toGroupLinkInfo :: (Maybe GroupId, Maybe GroupAcceptance, Maybe GroupMemberRole) -> Maybe GroupLinkInfo + toGroupLinkInfo (groupId_, acceptance_, mRole_) = + (\groupId -> GroupLinkInfo {groupId, acceptance = fromMaybe GAAuto acceptance_, memberRole = fromMaybe GRMember mRole_}) + <$> groupId_ getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink) getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) = diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 5865cd180e..3e7a326f67 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -128,6 +128,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_hist import Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions import Simplex.Chat.Store.SQLite.Migrations.M20250129_delete_unused_contacts import Simplex.Chat.Store.SQLite.Migrations.M20250130_indexes +import Simplex.Chat.Store.SQLite.Migrations.M20250227_member_acceptance import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -255,7 +256,8 @@ schemaMigrations = ("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), ("20250129_delete_unused_contacts", m20250129_delete_unused_contacts, Just down_m20250129_delete_unused_contacts), - ("20250130_indexes", m20250130_indexes, Just down_m20250130_indexes) + ("20250130_indexes", m20250130_indexes, Just down_m20250130_indexes), + ("20250227_member_acceptance", m20250227_member_acceptance, Just down_m20250227_member_acceptance) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 94b67d8349..fc2aa466aa 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -668,6 +668,7 @@ data GroupLinkInvitation = GroupLinkInvitation fromMemberName :: ContactName, invitedMember :: MemberIdRole, groupProfile :: GroupProfile, + acceptance :: Maybe GroupAcceptance, business :: Maybe BusinessChatInfo, groupSize :: Maybe Int } @@ -1001,6 +1002,7 @@ data GroupMemberStatus | GSMemIntroInvited -- member is sent to or received from intro invitation | GSMemAccepted -- member accepted invitation (only User and Invitee) | GSMemAnnounced -- host announced (x.grp.mem.new) a member (Invitee and PostMember) to the group - at this point this member can send messages and invite other members (if they have sufficient permissions) + | GSMemPendingApproval -- member is connected to host but pending host approval before connecting to other members ("knocking") | GSMemConnected -- member created the group connection with the inviting member | GSMemComplete -- host confirmed (x.grp.mem.all) that a member (User, Invitee and PostMember) created group connections with all previous members | GSMemCreator -- user member that created the group (only GCUserMember) @@ -1029,6 +1031,7 @@ memberActive m = case memberStatus m of GSMemIntroInvited -> False GSMemAccepted -> False GSMemAnnounced -> False + GSMemPendingApproval -> True -- TODO [knocking] ? GSMemConnected -> True GSMemComplete -> True GSMemCreator -> True @@ -1049,6 +1052,7 @@ memberCurrent' = \case GSMemIntroInvited -> True GSMemAccepted -> True GSMemAnnounced -> True + GSMemPendingApproval -> True GSMemConnected -> True GSMemComplete -> True GSMemCreator -> True @@ -1065,6 +1069,7 @@ memberRemoved m = case memberStatus m of GSMemIntroInvited -> False GSMemAccepted -> False GSMemAnnounced -> False + GSMemPendingApproval -> False GSMemConnected -> False GSMemComplete -> False GSMemCreator -> False @@ -1081,6 +1086,7 @@ instance TextEncoding GroupMemberStatus where "intro-inv" -> Just GSMemIntroInvited "accepted" -> Just GSMemAccepted "announced" -> Just GSMemAnnounced + "pending" -> Just GSMemPendingApproval "connected" -> Just GSMemConnected "complete" -> Just GSMemComplete "creator" -> Just GSMemCreator @@ -1096,6 +1102,7 @@ instance TextEncoding GroupMemberStatus where GSMemIntroInvited -> "intro-inv" GSMemAccepted -> "accepted" GSMemAnnounced -> "announced" + GSMemPendingApproval -> "pending" GSMemConnected -> "connected" GSMemComplete -> "complete" GSMemCreator -> "creator" diff --git a/src/Simplex/Chat/Types/Shared.hs b/src/Simplex/Chat/Types/Shared.hs index d5c8f48776..f0ed96b1af 100644 --- a/src/Simplex/Chat/Types/Shared.hs +++ b/src/Simplex/Chat/Types/Shared.hs @@ -48,3 +48,26 @@ instance FromJSON GroupMemberRole where instance ToJSON GroupMemberRole where toJSON = strToJSON toEncoding = strToJEncoding + +data GroupAcceptance = GAAuto | GAManual deriving (Eq, Show) + +instance FromField GroupAcceptance where fromField = blobFieldDecoder strDecode + +instance ToField GroupAcceptance where toField = toField . strEncode + +instance StrEncoding GroupAcceptance where + strEncode = \case + GAAuto -> "auto" + GAManual -> "manual" + strDecode = \case + "auto" -> Right GAAuto + "manual" -> Right GAManual + r -> Left $ "bad GroupAcceptance " <> B.unpack r + strP = strDecode <$?> A.takeByteString + +instance FromJSON GroupAcceptance where + parseJSON = strParseJSON "GroupAcceptance" + +instance ToJSON GroupAcceptance where + toJSON = strToJSON + toEncoding = strToJEncoding