From 58f6b168e60f2e45e5f749db290df6c37442fbc4 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 3 Oct 2022 09:00:47 +0100 Subject: [PATCH] core: protocol/commands to change member role (#1159) * core: protocol/commands to change member role * change member roles * add test * correction Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> * add member profile to group member role events * resend invitation when invited member role changes * test role change with invitation, fix * add delays to tests * add test delay Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- docs/protocol/simplex-chat.md | 2 + docs/protocol/simplex-chat.schema.json | 14 +++ src/Simplex/Chat.hs | 106 +++++++++++++++------ src/Simplex/Chat/Controller.hs | 2 + src/Simplex/Chat/Messages.hs | 10 +- src/Simplex/Chat/Protocol.hs | 7 ++ src/Simplex/Chat/Store.hs | 16 +++- src/Simplex/Chat/View.hs | 23 +++++ tests/ChatTests.hs | 127 ++++++++++++++++++------- 9 files changed, 240 insertions(+), 67 deletions(-) diff --git a/docs/protocol/simplex-chat.md b/docs/protocol/simplex-chat.md index 6c7a1e4541..f629f12bf8 100644 --- a/docs/protocol/simplex-chat.md +++ b/docs/protocol/simplex-chat.md @@ -213,6 +213,8 @@ Currently members can have one of three roles - `owner`, `admin` and `member`. T `x.grp.mem.info` this message is sent as part of member connection handshake - it includes group member profile. +`x.grp.mem.role` message is sent to update group member role - it is sent to all members by the member who updated the role of the member referenced in this message. This message MUST only be sent by members with `admin` or `owner` role. Receiving clients MUST ignore this message if it is received from member with role less than `admin`. + `x.grp.mem.del` message is sent to delete a member - it is sent to all members by the member who deletes the member referenced in this message. This message MUST only be sent by members with `admin` or `owner` role. Receiving clients MUST ignore this message if it is received from member with `member` role. `x.grp.leave` message is sent to all members by the member leaving the group. If the only group `owner` leaves the group, it will not be possible to delete it with `x.grp.del` message - but all members can still leave the group with `x.grp.leave` message and then delete a local copy of the group. diff --git a/docs/protocol/simplex-chat.schema.json b/docs/protocol/simplex-chat.schema.json index a0c6ec5706..020648a7a2 100644 --- a/docs/protocol/simplex-chat.schema.json +++ b/docs/protocol/simplex-chat.schema.json @@ -129,6 +129,9 @@ "directConnReq": {"ref": "connReqUri"} } }, + "groupMemberRole": { + "enum": ["author", "member", "admin", "owner"] + }, "callInvitation": { "properties": { "callType": {"ref": "callType"} @@ -374,6 +377,17 @@ } } }, + "x.grp.mem.role": { + "properties": { + "msgId": {"ref": "base64url"}, + "params": { + "properties": { + "memberId": {"ref": "base64url"}, + "role": {"ref": "groupMemberRole"} + } + } + } + }, "x.grp.mem.del": { "properties": { "msgId": {"ref": "base64url"}, diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 68c967bc92..f2110e0f5c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -787,8 +787,8 @@ processChatCommand = \case APIAddMember groupId contactId memRole -> withUser $ \user@User {userId} -> withChatLock $ do -- TODO for large groups: no need to load all members to determine if contact is a member (group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db userId contactId - let Group gInfo@GroupInfo {localDisplayName, groupProfile, membership} members = group - GroupMember {memberRole = userRole, memberId = userMemberId} = membership + let Group gInfo@GroupInfo {membership} members = group + GroupMember {memberRole = userRole} = membership Contact {localDisplayName = cName} = contact -- [incognito] forbid to invite contact to whom user is connected incognito when (contactConnIncognito contact) $ throwChatError CEContactIncognitoCantInvite @@ -797,24 +797,18 @@ processChatCommand = \case when (userRole < GRAdmin || userRole < memRole) $ throwChatError CEGroupUserRole when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined gInfo) unless (memberActive membership) $ throwChatError CEGroupMemberNotActive - let sendInvitation member@GroupMember {groupMemberId, memberId} cReq = do - let groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile - msg <- sendDirectContactMessage contact $ XGrpInv groupInv - let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole - ci <- saveSndChatItem user (CDDirectSnd contact) msg content Nothing Nothing - toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci - setActive $ ActiveG localDisplayName - pure $ CRSentGroupInvitation gInfo contact member + let sendInvitation = sendGrpInvitation user contact gInfo case contactMember contact members of Nothing -> do gVar <- asks idsDrg (agentConnId, cReq) <- withAgent $ \a -> createConnection a True SCMInvitation member <- withStore $ \db -> createNewContactMember db gVar user groupId contact memRole agentConnId cReq sendInvitation member cReq + pure $ CRSentGroupInvitation gInfo contact member Just member@GroupMember {groupMemberId, memberStatus} | memberStatus == GSMemInvited -> withStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case - Just cReq -> sendInvitation member cReq + Just cReq -> sendInvitation member cReq $> CRSentGroupInvitation gInfo contact member Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName APIJoinGroup groupId -> withUser $ \user@User {userId} -> do @@ -835,7 +829,32 @@ processChatCommand = \case let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole updateDirectChatItemView userId ct itemId aciContent Nothing _ -> pure () -- prohibited - APIMemberRole _groupId _groupMemberId _memRole -> throwChatError $ CECommandError "unsupported" + APIMemberRole groupId memberId memRole -> withUser $ \user -> do + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId + if memberId == groupMemberId' membership + then changeMemberRole user gInfo members membership $ SGEUserRole memRole + else case find ((== memberId) . groupMemberId') members of + Just m -> changeMemberRole user gInfo members m $ SGEMemberRole memberId (fromLocalProfile $ memberProfile m) memRole + _ -> throwChatError CEGroupMemberNotFound + where + changeMemberRole user@User {userId} gInfo@GroupInfo {membership} members m gEvent = do + let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m + GroupMember {memberRole = userRole} = membership + canChangeRole = userRole >= GRAdmin && userRole >= mRole && userRole >= memRole && memberCurrent membership + unless canChangeRole $ throwChatError CEGroupUserRole + withChatLock . procCmd $ do + unless (mRole == memRole) $ do + withStore' $ \db -> updateGroupMemberRole db user m memRole + case mStatus of + GSMemInvited -> do + withStore (\db -> (,) <$> mapM (getContact db userId) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case + (Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq + _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName + _ -> do + msg <- sendGroupMessage gInfo members $ XGrpMemRole mId memRole + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent) Nothing Nothing + toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci + pure CRMemberRoleUser {groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} APIRemoveMember groupId memberId -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId case find ((== memberId) . groupMemberId') members of @@ -1094,6 +1113,15 @@ 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 setExpireCIs :: (MonadUnliftIO m, MonadReader ChatController m) => Bool -> m () setExpireCIs b = do @@ -1698,6 +1726,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM XGrpMemIntro memInfo -> xGrpMemIntro gInfo m memInfo XGrpMemInv memId introInv -> xGrpMemInv gInfo m memId introInv XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m memInfo introInv + XGrpMemRole memId memRole -> xGrpMemRole gInfo m memId memRole msg msgMeta XGrpMemDel memId -> xGrpMemDel gInfo m memId msg msgMeta XGrpLeave -> xGrpLeave gInfo m msg msgMeta XGrpDel -> xGrpDel gInfo m msg msgMeta @@ -2357,32 +2386,53 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing withStore' $ \db -> createIntroToMemberContact db user m toMember groupConnIds directConnIds customUserProfileId + xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m () + xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta + | memberId (membership :: GroupMember) == memId = + let gInfo' = gInfo {membership = membership {memberRole = memRole}} + in changeMemberRole gInfo' membership $ RGEUserRole memRole + | otherwise = do + members <- withStore' $ \db -> getGroupMembers db user gInfo + case find (sameMemberId memId) members of + Just member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole + _ -> messageError "x.grp.mem.role with unknown member ID" + where + changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent + | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" + | otherwise = do + withStore' $ \db -> updateGroupMemberRole db user member memRole + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent) Nothing + groupMsgToView gInfo m ci msgMeta + toView CRMemberRole {groupInfo = gInfo', byMember = m, member, fromRole, toRole = memRole} + checkHostRole :: GroupMember -> GroupMemberRole -> m () checkHostRole GroupMember {memberRole, localDisplayName} memRole = when (memberRole < GRMember || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName) xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m () - xGrpMemDel gInfo@GroupInfo {membership} m memId msg msgMeta = do + xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg msgMeta = do members <- withStore' $ \db -> getGroupMembers db user gInfo if memberId (membership :: GroupMember) == memId - then do + then checkRole membership $ do forM_ members $ deleteMemberConnection user - withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEUserDeleted) Nothing - groupMsgToView gInfo m ci msgMeta + deleteMember membership RGEUserDeleted toView $ CRDeletedMemberUser gInfo {membership = membership {memberStatus = GSMemRemoved}} m else case find (sameMemberId memId) members of Nothing -> messageError "x.grp.mem.del with unknown member ID" - Just member@GroupMember {groupMemberId, memberProfile} -> do - let mRole = memberRole (m :: GroupMember) - if mRole < GRAdmin || mRole < memberRole (member :: GroupMember) - then messageError "x.grp.mem.del with insufficient member permissions" - else do - deleteMemberConnection user member - withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)) Nothing - groupMsgToView gInfo m ci msgMeta - toView $ CRDeletedMember gInfo m member {memberStatus = GSMemRemoved} + Just member@GroupMember {groupMemberId, memberProfile} -> + checkRole member $ do + deleteMemberConnection user member + deleteMember member $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) + toView $ CRDeletedMember gInfo m member {memberStatus = GSMemRemoved} + where + checkRole GroupMember {memberRole} a + | senderRole < GRAdmin || senderRole < memberRole = + messageError "x.grp.mem.del with insufficient member permissions" + | otherwise = a + deleteMember member gEvent = do + withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent) Nothing + groupMsgToView gInfo m ci msgMeta sameMemberId :: MemberId -> GroupMember -> Bool sameMemberId memId GroupMember {memberId} = memId == memberId @@ -2832,6 +2882,7 @@ chatCommandP = "/_ntf message " *> (APIGetNtfMessage <$> strP <* A.space <*> strP), "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_join #" *> (APIJoinGroup <$> A.decimal), + "/_member role #" *> (APIMemberRole <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal), "/_leave #" *> (APILeaveGroup <$> A.decimal), "/_members #" *> (APIListMembers <$> A.decimal), @@ -2859,6 +2910,7 @@ chatCommandP = "/_group " *> (NewGroup <$> jsonP), ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <* optional (A.char '@') <*> displayName <*> memberRole), ("/join #" <|> "/join " <|> "/j #" <|> "/j ") *> (JoinGroup <$> displayName), + ("/member role #" <|> "/member role " <|> "/mr #" <|> "/mr ") *> (MemberRole <$> displayName <* A.space <* optional (A.char '@') <*> displayName <*> memberRole), ("/remove #" <|> "/remove " <|> "/rm #" <|> "/rm ") *> (RemoveMember <$> displayName <* A.space <* optional (A.char '@') <*> displayName), ("/leave #" <|> "/leave " <|> "/l #" <|> "/l ") *> (LeaveGroup <$> displayName), ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 36eca8a625..ee1fd84670 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -302,6 +302,8 @@ data ChatResponse | CRUserJoinedGroup {groupInfo :: GroupInfo, hostMember :: GroupMember} | CRJoinedGroupMember {groupInfo :: GroupInfo, member :: GroupMember} | CRJoinedGroupMemberConnecting {groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember} + | CRMemberRole {groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole} + | CRMemberRoleUser {groupInfo :: GroupInfo, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole} | CRConnectedToGroupMember {groupInfo :: GroupInfo, member :: GroupMember} | CRDeletedMember {groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember} | CRDeletedMemberUser {groupInfo :: GroupInfo, member :: GroupMember} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 1196553f84..79ccb2cdcd 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -505,6 +505,8 @@ rcvGroupEventToText = \case RGEMemberAdded _ p -> "added " <> profileToText p RGEMemberConnected -> "connected" RGEMemberLeft -> "left" + RGEMemberRole _ p r -> "role of " <> profileToText p <> ": " <> safeDecodeUtf8 (strEncode r) + RGEUserRole r -> "your role: " <> safeDecodeUtf8 (strEncode r) RGEMemberDeleted _ p -> "removed " <> profileToText p RGEUserDeleted -> "removed you" RGEGroupDeleted -> "deleted group" @@ -512,6 +514,8 @@ rcvGroupEventToText = \case sndGroupEventToText :: SndGroupEvent -> Text sndGroupEventToText = \case + SGEMemberRole _ p r -> "role of " <> profileToText p <> ": " <> safeDecodeUtf8 (strEncode r) + SGEUserRole r -> "your role " <> safeDecodeUtf8 (strEncode r) SGEMemberDeleted _ p -> "removed " <> profileToText p SGEUserLeft -> "left" SGEGroupUpdated _ -> "group profile updated" @@ -544,6 +548,8 @@ data RcvGroupEvent = RGEMemberAdded {groupMemberId :: GroupMemberId, profile :: Profile} -- CRJoinedGroupMemberConnecting | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember | RGEMemberLeft -- CRLeftMember + | RGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} + | RGEUserRole {role :: GroupMemberRole} | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember | RGEUserDeleted -- CRDeletedMemberUser | RGEGroupDeleted -- CRGroupDeleted @@ -567,7 +573,9 @@ instance ToJSON DBRcvGroupEvent where toEncoding (RGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RGE") v data SndGroupEvent - = SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember + = SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} + | SGEUserRole {role :: GroupMemberRole} + | SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember | SGEUserLeft -- CRLeftMemberUser | SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated deriving (Show, Generic) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 0b9f6de869..6a3d044925 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -131,6 +131,7 @@ data ChatMsgEvent | XGrpMemInv MemberId IntroInvitation | XGrpMemFwd MemberInfo IntroInvitation | XGrpMemInfo MemberId Profile + | XGrpMemRole MemberId GroupMemberRole | XGrpMemCon MemberId -- TODO not implemented | XGrpMemConAll MemberId -- TODO not implemented | XGrpMemDel MemberId @@ -312,6 +313,7 @@ data CMEventTag | XGrpMemInv_ | XGrpMemFwd_ | XGrpMemInfo_ + | XGrpMemRole_ | XGrpMemCon_ | XGrpMemConAll_ | XGrpMemDel_ @@ -349,6 +351,7 @@ instance StrEncoding CMEventTag where XGrpMemInv_ -> "x.grp.mem.inv" XGrpMemFwd_ -> "x.grp.mem.fwd" XGrpMemInfo_ -> "x.grp.mem.info" + XGrpMemRole_ -> "x.grp.mem.role" XGrpMemCon_ -> "x.grp.mem.con" XGrpMemConAll_ -> "x.grp.mem.con.all" XGrpMemDel_ -> "x.grp.mem.del" @@ -383,6 +386,7 @@ instance StrEncoding CMEventTag where "x.grp.mem.inv" -> Right XGrpMemInv_ "x.grp.mem.fwd" -> Right XGrpMemFwd_ "x.grp.mem.info" -> Right XGrpMemInfo_ + "x.grp.mem.role" -> Right XGrpMemRole_ "x.grp.mem.con" -> Right XGrpMemCon_ "x.grp.mem.con.all" -> Right XGrpMemConAll_ "x.grp.mem.del" -> Right XGrpMemDel_ @@ -420,6 +424,7 @@ toCMEventTag = \case XGrpMemInv _ _ -> XGrpMemInv_ XGrpMemFwd _ _ -> XGrpMemFwd_ XGrpMemInfo _ _ -> XGrpMemInfo_ + XGrpMemRole _ _ -> XGrpMemRole_ XGrpMemCon _ -> XGrpMemCon_ XGrpMemConAll _ -> XGrpMemConAll_ XGrpMemDel _ -> XGrpMemDel_ @@ -486,6 +491,7 @@ appToChatMessage AppMessage {msgId, event, params} = do XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro" XGrpMemFwd_ -> XGrpMemFwd <$> p "memberInfo" <*> p "memberIntro" XGrpMemInfo_ -> XGrpMemInfo <$> p "memberId" <*> p "profile" + XGrpMemRole_ -> XGrpMemRole <$> p "memberId" <*> p "role" XGrpMemCon_ -> XGrpMemCon <$> p "memberId" XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId" XGrpMemDel_ -> XGrpMemDel <$> p "memberId" @@ -528,6 +534,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro] XGrpMemFwd memInfo memIntro -> o ["memberInfo" .= memInfo, "memberIntro" .= memIntro] XGrpMemInfo memId profile -> o ["memberId" .= memId, "profile" .= profile] + XGrpMemRole memId role -> o ["memberId" .= memId, "role" .= role] XGrpMemCon memId -> o ["memberId" .= memId] XGrpMemConAll memId -> o ["memberId" .= memId] XGrpMemDel memId -> o ["memberId" .= memId] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 35d7951b44..77e8457f82 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -89,6 +89,7 @@ module Simplex.Chat.Store createNewGroupMember, deleteGroupMember, deleteGroupMemberConnection, + updateGroupMemberRole, createIntroductions, updateIntroStatus, saveIntroInvitation, @@ -1412,8 +1413,15 @@ createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do liftIO getInvitationGroupId_ >>= \case Nothing -> createGroupInvitation_ - -- TODO treat the case that the invitation details could've changed - Just gId -> getGroupInfo db user gId + Just gId -> do + gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId + let GroupMember {groupMemberId, memberId, memberRole} = membership + MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember + liftIO . when (memberId /= memberId' || memberRole /= memberRole') $ + DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (memberId', memberRole', groupMemberId) + if p' == groupProfile + then pure gInfo + else updateGroupProfile db user gInfo groupProfile where getInvitationGroupId_ :: IO (Maybe Int64) getInvitationGroupId_ = @@ -1783,6 +1791,10 @@ deleteGroupMemberConnection :: DB.Connection -> User -> GroupMember -> IO () deleteGroupMemberConnection db User {userId} GroupMember {groupMemberId} = DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) +updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO () +updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = + DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId) + createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro] createIntroductions db members toMember = do let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 5c8ecb80b1..4393f2a714 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -149,6 +149,8 @@ responseToView testView = \case CRHostDisconnected p h -> [plain $ "disconnected from " <> viewHostEvent p h] CRJoinedGroupMemberConnecting g host m -> [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"] CRConnectedToGroupMember g m -> [ttyGroup' g <> ": " <> connectedMember m <> " is connected"] + CRMemberRole g by m r r' -> viewMemberRoleChanged g by m r r' + CRMemberRoleUser g m r r' -> viewMemberRoleUserChanged g m r r' CRDeletedMemberUser g by -> [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g CRDeletedMember g by m -> [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"] CRLeftMember g m -> [ttyGroup' g <> ": " <> ttyMember m <> " left the group"] @@ -478,6 +480,27 @@ connectedMember m = case memberCategory m of GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting _ -> "member " <> ttyMember m -- these case is not used +viewMemberRoleChanged :: GroupInfo -> GroupMember -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString] +viewMemberRoleChanged g@GroupInfo {membership} by m r r' + | r == r' = [ttyGroup' g <> ": member role did not change"] + | groupMemberId' membership == memId = view "your role" + | groupMemberId' by == memId = view "the role" + | otherwise = view $ "the role of " <> ttyMember m + where + memId = groupMemberId' m + view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r'] + +viewMemberRoleUserChanged :: GroupInfo -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString] +viewMemberRoleUserChanged g@GroupInfo {membership} m r r' + | r == r' = [ttyGroup' g <> ": member role did not change"] + | groupMemberId' membership == groupMemberId' m = view "your role" + | otherwise = view $ "the role of " <> ttyMember m + where + view s = [ttyGroup' g <> ": you changed " <> s <> " from " <> showRole r <> " to " <> showRole r'] + +showRole :: GroupMemberRole -> StyledString +showRole = plain . strEncode + viewGroupMembers :: Group -> [StyledString] viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members where diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 55b67df6fc..a9664f2675 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -19,7 +19,8 @@ import qualified Data.Text as T import Simplex.Chat.Call import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Options (ChatOpts (..)) -import Simplex.Chat.Types (ConnStatus (..), ImageData (..), LocalProfile (..), Profile (..), User (..)) +import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), ImageData (..), LocalProfile (..), Profile (..), User (..)) +import Simplex.Messaging.Encoding.String import Simplex.Messaging.Util (unlessM) import System.Directory (copyFile, doesDirectoryExist, doesFileExist) import System.FilePath (()) @@ -58,6 +59,7 @@ chatTests = do it "group message update" testGroupMessageUpdate it "group message delete" testGroupMessageDelete it "update group profile" testUpdateGroupProfile + it "update member role" testUpdateMemberRole describe "async group connections" $ do xit "create and join group when clients go offline" testGroupAsync describe "user profiles" $ do @@ -104,9 +106,9 @@ chatTests = do it "connect when accepting client goes offline" testAsyncAcceptingOffline describe "connect, fully asynchronous (when clients are never simultaneously online)" $ do it "v2" testFullAsync - -- it "v1" testFullAsyncV1 - -- it "v1 to v2" testFullAsyncV1toV2 - -- it "v2 to v1" testFullAsyncV2toV1 + -- it "v1" testFullAsyncV1 + -- it "v1 to v2" testFullAsyncV1toV2 + -- it "v2 to v1" testFullAsyncV2toV1 describe "async sending and receiving files" $ do xdescribe "send and receive file, fully asynchronous" $ do it "v2" testAsyncFileTransfer @@ -140,27 +142,28 @@ versionTestMatrix2 runTest = do versionTestMatrix3 :: (TestCC -> TestCC -> TestCC -> IO ()) -> Spec versionTestMatrix3 runTest = do it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest - -- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest - -- it "v1 to v2" . withTmpFiles $ - -- withNewTestChat "alice" aliceProfile $ \alice -> - -- withNewTestChatV1 "bob" bobProfile $ \bob -> - -- withNewTestChatV1 "cath" cathProfile $ \cath -> - -- runTest alice bob cath - -- it "v2+v1 to v2" . withTmpFiles $ - -- withNewTestChat "alice" aliceProfile $ \alice -> - -- withNewTestChat "bob" bobProfile $ \bob -> - -- withNewTestChatV1 "cath" cathProfile $ \cath -> - -- runTest alice bob cath - -- it "v2 to v1" . withTmpFiles $ - -- withNewTestChatV1 "alice" aliceProfile $ \alice -> - -- withNewTestChat "bob" bobProfile $ \bob -> - -- withNewTestChat "cath" cathProfile $ \cath -> - -- runTest alice bob cath - -- it "v2+v1 to v1" . withTmpFiles $ - -- withNewTestChatV1 "alice" aliceProfile $ \alice -> - -- withNewTestChat "bob" bobProfile $ \bob -> - -- withNewTestChatV1 "cath" cathProfile $ \cath -> - -- runTest alice bob cath + +-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest +-- it "v1 to v2" . withTmpFiles $ +-- withNewTestChat "alice" aliceProfile $ \alice -> +-- withNewTestChatV1 "bob" bobProfile $ \bob -> +-- withNewTestChatV1 "cath" cathProfile $ \cath -> +-- runTest alice bob cath +-- it "v2+v1 to v2" . withTmpFiles $ +-- withNewTestChat "alice" aliceProfile $ \alice -> +-- withNewTestChat "bob" bobProfile $ \bob -> +-- withNewTestChatV1 "cath" cathProfile $ \cath -> +-- runTest alice bob cath +-- it "v2 to v1" . withTmpFiles $ +-- withNewTestChatV1 "alice" aliceProfile $ \alice -> +-- withNewTestChat "bob" bobProfile $ \bob -> +-- withNewTestChat "cath" cathProfile $ \cath -> +-- runTest alice bob cath +-- it "v2+v1 to v1" . withTmpFiles $ +-- withNewTestChatV1 "alice" aliceProfile $ \alice -> +-- withNewTestChat "bob" bobProfile $ \bob -> +-- withNewTestChatV1 "cath" cathProfile $ \cath -> +-- runTest alice bob cath testAddContact :: Spec testAddContact = versionTestMatrix2 runTestAddContact @@ -1095,6 +1098,52 @@ testUpdateGroupProfile = (alice <# "#my_team bob> hi") (cath <# "#my_team bob> hi") +testUpdateMemberRole :: IO () +testUpdateMemberRole = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + connectUsers alice bob + alice ##> "/g team" + alice <## "group #team is created" + alice <## "use /a team to add members" + addMember "team" alice bob GRAdmin + alice ##> "/mr team bob member" + alice <## "#team: you changed the role of bob from admin to member" + bob <## "#team: alice invites you to join the group as member" + bob <## "use /j team to accept" + bob ##> "/j team" + concurrently_ + (alice <## "#team: bob joined the group") + (bob <## "#team: you joined the group") + connectUsers bob cath + bob ##> "/a team cath" + bob <## "you have insufficient permissions for this group command" + alice ##> "/mr team bob admin" + concurrently_ + (alice <## "#team: you changed the role of bob from member to admin") + (bob <## "#team: alice changed your role from member to admin") + bob ##> "/a team cath owner" + bob <## "you have insufficient permissions for this group command" + addMember "team" bob cath GRMember + 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: bob added cath (Catherine) to the group (connecting...)" + alice <## "#team: new member cath is connected" + ] + alice ##> "/mr team alice admin" + concurrentlyN_ + [ alice <## "#team: you changed your role from owner to admin", + bob <## "#team: alice changed the role from owner to admin", + cath <## "#team: alice changed the role from owner to admin" + ] + alice ##> "/d #team" + alice <## "you have insufficient permissions for this group command" + testGroupAsync :: IO () testGroupAsync = withTmpFiles $ do print (0 :: Integer) @@ -2388,8 +2437,8 @@ testSetConnectionAlias = testChat2 aliceProfile bobProfile $ bob ##> ("/c " <> inv) bob <## "confirmation sent!" concurrently_ - (alice <## ("bob (Bob): contact is connected")) - (bob <## ("alice (Alice): contact is connected")) + (alice <## "bob (Bob): contact is connected") + (bob <## "alice (Alice): contact is connected") alice @@@ [("@bob", "")] alice ##> "/cs" alice <## "bob (Bob) (alias: friend)" @@ -2416,10 +2465,11 @@ testAsyncInitiatingOffline = withTmpFiles $ do getInvitation alice putStrLn "3" withNewTestChat "bob" bobProfile $ \bob -> do + threadDelay 250000 putStrLn "4" - bob `send` ("/c " <> inv) + bob ##> ("/c " <> inv) putStrLn "5" - bob <### ["/c " <> inv, "confirmation sent!"] + bob <## "confirmation sent!" putStrLn "6" withTestChat "alice" $ \alice -> do putStrLn "7" @@ -2437,6 +2487,7 @@ testAsyncAcceptingOffline = withTmpFiles $ do getInvitation alice putStrLn "3" withNewTestChat "bob" bobProfile $ \bob -> do + threadDelay 250000 putStrLn "4" bob ##> ("/c " <> inv) putStrLn "5" @@ -2454,16 +2505,18 @@ testFullAsync :: IO () testFullAsync = withTmpFiles $ do putStrLn "testFullAsync" inv <- withNewTestChat "alice" aliceProfile $ \alice -> do + threadDelay 250000 putStrLn "1" alice ##> "/c" putStrLn "2" getInvitation alice putStrLn "3" withNewTestChat "bob" bobProfile $ \bob -> do + threadDelay 250000 putStrLn "4" - bob `send` ("/c " <> inv) + bob ##> ("/c " <> inv) putStrLn "5" - bob <### ["/c " <> inv, "confirmation sent!"] + bob <## "confirmation sent!" putStrLn "6" withTestChat "alice" $ \_ -> pure () -- connecting... notification in UI putStrLn "7" @@ -3066,7 +3119,7 @@ createGroup2 gName cc1 cc2 = do cc1 ##> ("/g " <> gName) cc1 <## ("group #" <> gName <> " is created") cc1 <## ("use /a " <> gName <> " to add members") - addMember gName cc1 cc2 + addMember gName cc1 cc2 GRAdmin cc2 ##> ("/j " <> gName) concurrently_ (cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group")) @@ -3079,7 +3132,7 @@ createGroup3 gName cc1 cc2 cc3 = do name3 <- userName cc3 sName2 <- showName cc2 sName3 <- showName cc3 - addMember gName cc1 cc3 + addMember gName cc1 cc3 GRAdmin cc3 ##> ("/j " <> gName) concurrentlyN_ [ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"), @@ -3091,15 +3144,15 @@ createGroup3 gName cc1 cc2 cc3 = do cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected") ] -addMember :: String -> TestCC -> TestCC -> IO () -addMember gName inviting invitee = do +addMember :: String -> TestCC -> TestCC -> GroupMemberRole -> IO () +addMember gName inviting invitee role = do name1 <- userName inviting memName <- userName invitee - inviting ##> ("/a " <> gName <> " " <> memName) + inviting ##> ("/a " <> gName <> " " <> memName <> " " <> B.unpack (strEncode role)) concurrentlyN_ [ inviting <## ("invitation to join the group #" <> gName <> " sent to " <> memName), do - invitee <## ("#" <> gName <> ": " <> name1 <> " invites you to join the group as admin") + invitee <## ("#" <> gName <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role)) invitee <## ("use /j " <> gName <> " to accept") ]