lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

core: protocol/commands to change member role (#1159)

Browse source 
* 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>
This commit is contained in:
Evgeny Poberezkin 2022-10-03 09:00:47 +01:00 • committed by GitHub
parent 841afa1e80
commit 58f6b168e6
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
9 changed files with 240 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
docs/protocol/simplex-chat.md
View file

@ -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.

14
docs/protocol/simplex-chat.schema.json
View file

@ -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"},

106
src/Simplex/Chat.hs
View file

@ -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),

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

@ -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}

10
src/Simplex/Chat/Messages.hs
View file

@ -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)

7
src/Simplex/Chat/Protocol.hs
View file

@ -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]

16
src/Simplex/Chat/Store.hs
View file

@ -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

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

@ -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

127
tests/ChatTests.hs
View file

@ -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 <name> 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 <> " <name> 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")
]