diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index f066ea26c3..821bc3d6ce 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -633,6 +633,7 @@ processChatCommand' vr = \case then do ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions let mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions + -- TODO [knocking] send separately to pending approval member SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime @@ -687,6 +688,7 @@ processChatCommand' vr = \case assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier let msgIds = itemsMsgIds items events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds + -- TODO [knocking] validate: only current members or only single pending approval member mapM_ (sendGroupMessages user gInfo ms) events delGroupChatItems user gInfo items False CTLocal -> do @@ -764,6 +766,7 @@ processChatCommand' vr = \case let GroupMember {memberId = itemMemberId} = chatItemMember g ci rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs + -- TODO [knocking] send separately to pending approval member SndMessage {msgId} <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) createdAt <- liftIO getCurrentTime reactions <- withFastStore' $ \db -> do @@ -1084,6 +1087,7 @@ processChatCommand' vr = \case cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo let doSendDel = memberActive membership && isOwner + -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) when doSendDel . void $ sendGroupMessage' user gInfo members XGrpDel deleteGroupLinkIfExists user gInfo deleteMembersConnections' user members doSendDel @@ -2040,10 +2044,11 @@ processChatCommand' vr = \case withGroupLock "memberRole" groupId . procCmd $ do g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId when (selfSelected gInfo) $ throwChatError $ CECommandError "can't change role for self" - let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin) = selectMembers members + let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $ throwChatError $ CECommandError "can't change role of multiple members when admins selected, or new role is admin" + when anyPending $ throwChatError $ CECommandError "can't change role of members pending approval" assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole]) (errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems (errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems @@ -2053,19 +2058,20 @@ processChatCommand' vr = \case pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed where selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], [], GRObserver, False) + selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool) + selectMembers = foldr' addMember ([], [], [], GRObserver, False, False) where - addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin) + addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending) | groupMemberId `elem` memberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin + anyPending' = anyPending || memberStatus == GSMemPendingApproval in if - | memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin') - | memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin') - | otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin') - | otherwise = (invited, current, unchanged, maxRole, anyAdmin) + | memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending') + | memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending') + | otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending') + | otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending) changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember]) changeRoleInvitedMems user gInfo memsToChange = do -- not batched, as we need to send different invitations to different connections anyway @@ -2105,22 +2111,24 @@ processChatCommand' vr = \case withGroupLock "blockForAll" groupId . procCmd $ do Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId when (selfSelected gInfo) $ throwChatError $ CECommandError "can't block/unblock self" - let (blockMems, remainingMems, maxRole, anyAdmin) = selectMembers members + let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't block/unblock multiple members when admins selected" + when anyPending $ throwChatError $ CECommandError "can't block/unblock members pending approval" assertUserGroupRole gInfo $ max GRModerator maxRole blockMembers user gInfo blockMems remainingMems where selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], GRObserver, False) + selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool, Bool) + selectMembers = foldr' addMember ([], [], GRObserver, False, False) where - addMember m@GroupMember {groupMemberId, memberRole} (block, remaining, maxRole, anyAdmin) + addMember m@GroupMember {groupMemberId, memberRole, memberStatus} (block, remaining, maxRole, anyAdmin, anyPending) | groupMemberId `elem` memberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin - in (m : block, remaining, maxRole', anyAdmin') - | otherwise = (block, m : remaining, maxRole, anyAdmin) + anyPending' = anyPending || memberStatus == GSMemPendingApproval + in (m : block, remaining, maxRole', anyAdmin', anyPending') + | otherwise = (block, m : remaining, maxRole, anyAdmin, anyPending) blockMembers :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ChatResponse blockMembers user gInfo blockMems remainingMems = case L.nonEmpty blockMems of Nothing -> throwChatError $ CECommandError "no members to block/unblock" @@ -2146,30 +2154,34 @@ processChatCommand' vr = \case in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing APIRemoveMembers groupId memberIds -> withUser $ \user -> withGroupLock "removeMembers" groupId . procCmd $ do - g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId - let (invitedMems, currentMems, maxRole, anyAdmin) = selectMembers members - when (length invitedMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound + Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId + let (invitedMems, pendingMems, currentMems, maxRole, anyAdmin) = selectMembers members + when (length invitedMems + length pendingMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected" assertUserGroupRole gInfo $ max GRAdmin maxRole (errs1, deleted1) <- deleteInvitedMems user invitedMems - (errs2, deleted2, acis) <- deleteCurrentMems user g currentMems + (errs2, deleted2, acis2) <- deleteMemsSend user gInfo members currentMems + rs <- forM pendingMems $ \m -> deleteMemsSend user gInfo [m] [m] + let (errs3, deleted3, acis3) = concatTuples rs + acis = acis2 <> acis3 + errs = errs1 <> errs2 <> errs3 unless (null acis) $ toView $ CRNewChatItems user acis - let errs = errs1 <> errs2 unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2) -- same order is not guaranteed + pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2 <> deleted3) -- same order is not guaranteed where - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], GRObserver, False) + selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) + selectMembers = foldr' addMember ([], [], [], GRObserver, False) where - addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, maxRole, anyAdmin) + addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, pending, current, maxRole, anyAdmin) | groupMemberId `elem` memberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin in - if memberStatus == GSMemInvited - then (m : invited, current, maxRole', anyAdmin') - else (invited, m : current, maxRole', anyAdmin') - | otherwise = (invited, current, maxRole, anyAdmin) + case memberStatus of + GSMemInvited -> (m : invited, pending, current, maxRole', anyAdmin') + GSMemPendingApproval -> (invited, m : pending, current, maxRole', anyAdmin') + _ -> (invited, pending, m : current, maxRole', anyAdmin') + | otherwise = (invited, pending, current, maxRole, anyAdmin) deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember]) deleteInvitedMems user memsToDelete = do deleteMembersConnections user memsToDelete @@ -2178,12 +2190,12 @@ processChatCommand' vr = \case delMember db m = do deleteGroupMember db user m pure m {memberStatus = GSMemRemoved} - deleteCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem]) - deleteCurrentMems user (Group gInfo members) memsToDelete = case L.nonEmpty memsToDelete of + deleteMemsSend :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem]) + deleteMemsSend user gInfo sendToMems memsToDelete = case L.nonEmpty memsToDelete of Nothing -> pure ([], [], []) Just memsToDelete' -> do let events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId) memsToDelete' - (msgs_, _gsr) <- sendGroupMessages user gInfo members events + (msgs_, _gsr) <- sendGroupMessages user gInfo sendToMems events let itemsData = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_) cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False when (length cis_ /= length memsToDelete) $ logError "deleteCurrentMems: memsToDelete and cis_ length mismatch" @@ -2200,11 +2212,15 @@ processChatCommand' vr = \case delMember db m = do deleteOrUpdateMemberRecordIO db user m pure m {memberStatus = GSMemRemoved} + concatTuples :: [([a], [b], [c])] -> ([a], [b], [c]) + concatTuples xs = (concat as, concat bs, concat cs) + where (as, bs, cs) = unzip3 xs APILeaveGroup groupId -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo withGroupLock "leaveGroup" groupId . procCmd $ do cancelFilesInProgress user filesInfo + -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) msg <- sendGroupMessage' user gInfo members XGrpLeave ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] @@ -2417,6 +2433,7 @@ processChatCommand' vr = \case void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId Just (ChatRef CTGroup groupId) -> do (Group gInfo ms, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId + -- TODO [knocking] send separately to pending approval member void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId @@ -2809,6 +2826,7 @@ processChatCommand' vr = \case GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} <- withStore $ \db -> getGroupMemberByMemberId db vr user g businessId let p'' = p' {displayName, fullName, image} :: GroupProfile + -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) void $ sendGroupMessage user g' oldMs (XGrpInfo p'') let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' sendGroupMessage user g' newMs $ XGrpPrefs ps' @@ -2837,6 +2855,8 @@ processChatCommand' vr = \case assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate let msgMemIds = itemsMsgMemIds gInfo items events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds + -- TODO [knocking] validate: only current members or only single pending approval member, + -- TODO or prohibit pending approval members (only moderation and reports use this) mapM_ (sendGroupMessages user gInfo ms) events delGroupChatItems user gInfo items True where @@ -3182,9 +3202,9 @@ processChatCommand' vr = \case sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} notInHistory_ ms numFileInvs live itemTTL cmrs = do -- TODO [knocking] pass GroupSndScope? let allowedRole = case ms of - [m] | memberCategory m == GCHostMember && memberStatus membership == GSMemPendingApproval -> GRObserver - _ -> GRAuthor - assertUserGroupRole gInfo allowedRole + [m] | memberCategory m == GCHostMember && memberStatus membership == GSMemPendingApproval -> Nothing + _ -> Just GRAuthor + forM_ allowedRole $ assertUserGroupRole gInfo assertGroupContentAllowed processComposedMessages where diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index b8aedbebbd..b90a1312bf 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -1589,6 +1589,7 @@ sendGroupMessage' user gInfo members chatMsgEvent = sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) sendGroupMessages user gInfo members events = do + -- TODO [knocking] when sending to all, send profile update to pending approval members too, then filter for next step? when shouldSendProfileUpdate $ sendProfileUpdate `catchChatError` (toView . CRChatError (Just user)) sendGroupMessages_ user gInfo members events diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 998835b867..d752b8c00e 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -54,7 +54,7 @@ chatDirectTests = do describe "direct messages" $ do describe "add contact and send/receive messages" testAddContact it "retry connecting via the same link" testRetryConnecting - xit'' "retry connecting via the same link with client timeout" testRetryConnectingClientTimeout + it "retry connecting via the same link with client timeout" testRetryConnectingClientTimeout it "mark multiple messages as read" testMarkReadDirect it "clear chat with contact" testContactClear it "deleting contact deletes profile" testDeleteContactDeletesProfile diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 30c3cb5536..704fbd02eb 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -102,6 +102,7 @@ chatGroupTests = do it "reject member joining via group link - blocked name" testGLinkRejectBlockedName describe "group links - manual acceptance" $ do it "manually accept member joining via group link" testGLinkManualAcceptMember + it "delete pending member" testGLinkDeletePendingMember describe "group link connection plan" $ do it "ok to connect; known group" testPlanGroupLinkKnown it "own group link" testPlanGroupLinkOwn @@ -2961,6 +2962,31 @@ testGLinkManualAcceptMember = where cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Right (GAManual, GRObserver))}} +testGLinkDeletePendingMember :: HasCallStack => TestParams -> IO () +testGLinkDeletePendingMember = + testChatCfg3 cfg aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup2 "team" alice bob + + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + cath ##> ("/c " <> gLink) + cath <## "connection request sent!" + alice <## "cath (Catherine): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: cath connected and pending approval, use /_accept member #1 3 to accept member", + do + cath <## "#team: joining the group..." + cath <## "#team: you joined the group, pending approval" + ] + + alice ##> "/rm team cath" + alice <## "#team: you removed cath from the group" + cath <## "#team: alice removed you from the group" + cath <## "use /d #team to delete the group" + where + cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Right (GAManual, GRObserver))}} + testPlanGroupLinkKnown :: HasCallStack => TestParams -> IO () testPlanGroupLinkKnown = testChat2 aliceProfile bobProfile $