From 16f53490c5156e4224044813b7fb694eba444e0d Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 19 Jan 2024 17:57:04 +0400 Subject: [PATCH] core: block member for all (#3689) * core: silence member wip * change approach * more types * remove comment * bool in protocol msg * flag in items, event * send event, process * apply moderation * remove comment * filter for forward, view * tests * rename * separate response, check already blocked * add test * fix terminal api * add comment * don't send profile update * corrections * refactor * rework - flag blocked by admin * blocked in intro * fix test * cant block unblock self * muted view, create unknown member * blocked by admin in members list * create with maybe null * protocol changes * align code with protocol * revert terminal api * restrict block api for admins * stabilize test * rename * update protocol/types * refactor * refactor2 * stabilize test * member field --------- Co-authored-by: Evgeny Poberezkin --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 164 +++++++-- src/Simplex/Chat/Controller.hs | 6 + src/Simplex/Chat/Messages.hs | 5 + src/Simplex/Chat/Messages/CIContent.hs | 13 + src/Simplex/Chat/Messages/CIContent/Events.hs | 2 + .../M20240115_block_member_for_all.hs | 18 + src/Simplex/Chat/Migrations/chat_schema.sql | 1 + src/Simplex/Chat/Protocol.hs | 24 +- src/Simplex/Chat/Store/Connections.hs | 4 +- src/Simplex/Chat/Store/Groups.hs | 100 +++-- src/Simplex/Chat/Store/Messages.hs | 54 ++- src/Simplex/Chat/Store/Migrations.hs | 4 +- src/Simplex/Chat/Types.hs | 59 ++- src/Simplex/Chat/View.hs | 34 +- tests/ChatTests/Direct.hs | 29 +- tests/ChatTests/Groups.hs | 345 +++++++++++++++++- tests/ProtocolTests.hs | 7 +- 18 files changed, 751 insertions(+), 119 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20240115_block_member_for_all.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 22113f3c29..2cbc790c23 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -131,6 +131,7 @@ library Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries Simplex.Chat.Migrations.M20240102_note_folders Simplex.Chat.Migrations.M20240104_members_profile_update + Simplex.Chat.Migrations.M20240115_block_member_for_all Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b87f6a7d00..fcb7be61b6 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1290,9 +1290,8 @@ processChatCommand' vr = \case m <- withStore $ \db -> do liftIO $ updateGroupMemberSettings db user gId gMemberId settings getGroupMember db user gId gMemberId - when (memberActive m) $ forM_ (memberConnId m) $ \connId -> do - let ntfOn = showMessages $ memberSettings m - withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) + let ntfOn = showMessages $ memberSettings m + toggleNtf user m ntfOn ok user APIContactInfo contactId -> withUser $ \user@User {userId} -> do -- [incognito] print user's incognito profile for this contact @@ -1410,7 +1409,10 @@ processChatCommand' vr = \case SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_}) SetShowMemberMessages gName mName showMessages -> withUser $ \user -> do (gId, mId) <- getGroupAndMemberId user gName mName + gInfo <- withStore $ \db -> getGroupInfo db vr user gId m <- withStore $ \db -> getGroupMember db user gId mId + let GroupInfo {membership = GroupMember {memberRole = membershipRole}} = gInfo + when (membershipRole >= GRAdmin) $ throwChatError $ CECantBlockMemberForSelf gInfo m showMessages let settings = (memberSettings m) {showMessages} processChatCommand $ APISetMemberSettings gId mId settings ContactInfo cName -> withContactName cName APIContactInfo @@ -1721,6 +1723,31 @@ processChatCommand' vr = \case ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} + APIBlockMemberForAll groupId memberId blocked -> withUser $ \user -> do + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId + when (memberId == groupMemberId' membership) $ throwChatError $ CECommandError "can't block/unblock self" + case splitMember memberId members of + Nothing -> throwChatError $ CEException "expected to find a single blocked member" + Just (bm, remainingMembers) -> do + let GroupMember {memberId = bmMemberId, memberRole = bmRole, memberProfile = bmp} = bm + assertUserGroupRole gInfo $ max GRAdmin bmRole + when (blocked == blockedByAdmin bm) $ throwChatError $ CECommandError $ if blocked then "already blocked" else "already unblocked" + withChatLock "blockForAll" . procCmd $ do + let mrs = if blocked then MRSBlocked else MRSUnrestricted + event = XGrpMemRestrict bmMemberId MemberRestrictions {restriction = mrs} + (msg, _) <- sendGroupMessage' user gInfo remainingMembers event + let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent + toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + bm' <- withStore $ \db -> do + liftIO $ updateGroupMemberBlocked db user groupId memberId mrs + getGroupMember db user groupId memberId + toggleNtf user bm' (not blocked) + pure CRMemberBlockedForAllUser {user, groupInfo = gInfo, member = bm', blocked} + where + splitMember mId ms = case break ((== mId) . groupMemberId') ms of + (_, []) -> Nothing + (ms1, bm : ms2) -> Just (bm, ms1 <> ms2) APIRemoveMember groupId memberId -> withUser $ \user -> do Group gInfo members <- withStore $ \db -> getGroup db vr user groupId case find ((== memberId) . groupMemberId') members of @@ -1761,6 +1788,7 @@ processChatCommand' vr = \case groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIJoinGroup groupId MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMemberRole gId gMemberId memRole + BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMemberForAll gId gMemberId blocked RemoveMember gName gMemberName -> withMemberName gName gMemberName APIRemoveMember LeaveGroup gName -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName @@ -2487,6 +2515,12 @@ processChatCommand' vr = \case cReqHashes = bimap hash hash cReqSchemas hash = ConnReqUriHash . C.sha256Hash . strEncode +toggleNtf :: ChatMonad m => User -> GroupMember -> Bool -> m () +toggleNtf user m ntfOn = + when (memberActive m) $ + forM_ (memberConnId m) $ \connId -> + withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) + data ChangedProfileContact = ChangedProfileContact { ct :: Contact, ct' :: Contact, @@ -3723,11 +3757,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = shuffledIntros <- liftIO $ shuffleIntros intros if isCompatibleRange (memberChatVRange' m) batchSendVRange then do - let events = map (XGrpMemIntro . memberInfo . reMember) shuffledIntros + let events = map (memberIntro . reMember) shuffledIntros forM_ (L.nonEmpty events) $ \events' -> sendGroupMemberMessages user conn events' groupId else forM_ shuffledIntros $ \intro -> processIntro intro `catchChatError` (toView . CRChatError (Just user)) + memberIntro :: GroupMember -> ChatMsgEvent 'Json + memberIntro reMember = + let mInfo = memberInfo reMember + mRestrictions = memberRestrictions reMember + in XGrpMemIntro mInfo mRestrictions shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] shuffleIntros intros = do let (admins, others) = partition isAdmin intros @@ -3738,7 +3777,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image processIntro intro@GroupMemberIntro {introId} = do - void $ sendDirectMessage conn (XGrpMemIntro $ memberInfo (reMember intro)) (GroupId groupId) + void $ sendDirectMessage conn (memberIntro $ reMember intro) (GroupId groupId) withStore' $ \db -> updateIntroStatus db introId GMIntroSent sendHistory = when (isCompatibleRange (memberChatVRange' m) batchSendVRange) $ do @@ -3757,9 +3796,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | otherwise = Nothing itemForwardEvents :: CChatItem 'CTGroup -> m [ChatMsgEvent 'Json] itemForwardEvents cci = case cci of - (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) -> do - fInvDescr_ <- join <$> forM file getRcvFileInvDescr - processContentItem sender ci mc fInvDescr_ + (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) + | not (blockedByAdmin sender) -> do + fInvDescr_ <- join <$> forM file getRcvFileInvDescr + processContentItem sender ci mc fInvDescr_ (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do fInvDescr_ <- join <$> forM file getSndFileInvDescr processContentItem membership ci mc fInvDescr_ @@ -3855,7 +3895,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = checkSendRcpt $ rights aChatMsgs -- currently only a single message is forwarded let GroupMember {memberRole = membershipMemRole} = membership - when (membershipMemRole >= GRAdmin) $ case aChatMsgs of + when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ case aChatMsgs of [Right (ACMsg _ chatMsg)] -> forwardMsg_ chatMsg _ -> pure () where @@ -3877,10 +3917,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XInfo p -> xInfoMember gInfo m' p XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs - XGrpMemIntro memInfo -> xGrpMemIntro gInfo m' memInfo + XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo m' memInfo memRestrictions_ 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 brokerTs + XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo m' memId memRestrictions msg brokerTs XGrpMemCon memId -> xGrpMemCon gInfo m' memId XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs XGrpLeave -> xGrpLeave gInfo m' msg brokerTs @@ -3916,7 +3957,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- invited members to which this member was introduced invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable let GroupMember {memberId} = m - ms = introducedMembers <> invitedMembers + ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) chatMsg' msg = XGrpMsgForward memberId chatMsg' brokerTs unless (null ms) . void $ sendGroupMessage' user gInfo ms msg @@ -4506,37 +4547,49 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> m () newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded + | blockedByAdmin m = createBlockedByAdmin | isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice | not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles - | otherwise = do - let timed_ = - if forwarded - then rcvCITimed_ (Just Nothing) itemTTL - else rcvGroupCITimed gInfo itemTTL - live = fromMaybe False live_ + | otherwise = withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case Just ciModeration -> do - applyModeration timed_ live ciModeration + applyModeration ciModeration withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ - Nothing -> createItem timed_ live + Nothing -> createContentItem where rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False + timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL + live' = fromMaybe False live_ ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc - applyModeration timed_ live CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt} - | moderatorRole < GRAdmin || moderatorRole < memberRole = - createItem timed_ live + createBlockedByAdmin | groupFeatureAllowed SGFFullDelete gInfo = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed_ False - ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt - toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci' + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvBlocked Nothing timed' False + ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs + groupMsgToView gInfo ci' | otherwise = do - file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed_ False + file_ <- processFileInv + ci <- createNonLive file_ + ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo ci + groupMsgToView gInfo ci' + applyModeration CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt} + | moderatorRole < GRAdmin || moderatorRole < memberRole = + createContentItem + | groupFeatureAllowed SGFFullDelete gInfo = do + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed' False + ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt + groupMsgToView gInfo ci' + | otherwise = do + file_ <- processFileInv + ci <- createNonLive file_ toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt - createItem timed_ live = do - file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m - newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live + createNonLive file_ = + saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed' False + createContentItem = do + file_ <- processFileInv + newChatItem (CIRcvMsgContent content) (snd <$> file_) timed' live' when (showMessages $ memberSettings m) $ autoAcceptFile file_ + processFileInv = + processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m newChatItem ciContent ciFile_ timed_ live = do ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci @@ -5226,8 +5279,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = groupMsgToView gInfo ci toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember - xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m () - xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) = do + xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> m () + xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do case memberCategory m of GCHostMember -> withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case @@ -5243,7 +5296,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | isCompatibleRange (fromChatVRange mcvr) groupNoDirectVRange -> pure Nothing | otherwise -> Just <$> createConn subMode let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo - void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode + void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo memRestrictions groupConnIds directConnIds customUserProfileId subMode _ -> messageError "x.grp.mem.intro can be only sent by host member" where createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode @@ -5315,6 +5368,40 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = checkHostRole GroupMember {memberRole, localDisplayName} memRole = when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName) + xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> m () + xGrpMemRestrict + gInfo@GroupInfo {groupId, membership = GroupMember {memberId = membershipMemId}} + m@GroupMember {memberRole = senderRole} + memId + MemberRestrictions {restriction} + msg + brokerTs + | membershipMemId == memId = + -- member shouldn't receive this message about themselves + messageError "x.grp.mem.restrict: admin blocks you" + | otherwise = + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + Right bm@GroupMember {groupMemberId = bmId, memberRole, memberProfile = bmp} + | senderRole < GRAdmin || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" + | otherwise -> do + bm' <- setMemberBlocked bmId + toggleNtf user bm' (not blocked) + let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs ciContent + groupMsgToView gInfo ci + toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked} + Left (SEGroupMemberNotFoundByMemberId _) -> do + bm <- createUnknownMember gInfo memId + bm' <- setMemberBlocked $ groupMemberId' bm + toView $ CRUnknownMemberBlocked user gInfo m bm' + Left e -> throwError $ ChatErrorStore e + where + setMemberBlocked bmId = + withStore $ \db -> do + liftIO $ updateGroupMemberBlocked db user groupId bmId restriction + getGroupMember db user groupId bmId + blocked = mrsBlocked restriction + xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> m () xGrpMemCon gInfo sendingMember memId = do refMember <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memId @@ -5474,8 +5561,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memberId) >>= \case Right author -> processForwardedMsg author msg Left (SEGroupMemberNotFoundByMemberId _) -> do - let name = T.take 7 . safeDecodeUtf8 . B64.encode . unMemberId $ memberId - unknownAuthor <- withStore $ \db -> createNewUnknownGroupMember db vr user gInfo memberId name + unknownAuthor <- createUnknownMember gInfo memberId toView $ CRUnknownMemberCreated user gInfo m unknownAuthor processForwardedMsg unknownAuthor msg Left e -> throwError $ ChatErrorStore e @@ -5501,6 +5587,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) + createUnknownMember :: GroupInfo -> MemberId -> m GroupMember + createUnknownMember gInfo memberId = do + let name = T.take 7 . safeDecodeUtf8 . B64.encode . unMemberId $ memberId + withStore $ \db -> createNewUnknownGroupMember db vr user gInfo memberId name + directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m () directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do checkIntegrityCreateItem (CDDirectRcv ct) msgMeta @@ -6437,6 +6528,7 @@ chatCommandP = "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_join #" *> (APIJoinGroup <$> A.decimal), "/_member role #" *> (APIMemberRole <$> A.decimal <* A.space <*> A.decimal <*> memberRole), + "/_block #" *> (APIBlockMemberForAll <$> A.decimal <* A.space <*> A.decimal <* A.space <* "blocked=" <*> onOffP), "/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal), "/_leave #" *> (APILeaveGroup <$> A.decimal), "/_members #" *> (APIListMembers <$> A.decimal), @@ -6506,6 +6598,8 @@ chatCommandP = ("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> (memberRole <|> pure GRMember)), ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayName), ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayName <* A.space <* char_ '@' <*> displayName <*> memberRole), + "/block for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True), + "/unblock for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False), ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMember <$> displayName <* A.space <* char_ '@' <*> displayName), ("/leave " <|> "/l ") *> char_ '#' *> (LeaveGroup <$> displayName), ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index aece4ef1a7..d3c8698f94 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -294,6 +294,7 @@ data ChatCommand | APIAddMember GroupId ContactId GroupMemberRole | APIJoinGroup GroupId | APIMemberRole GroupId GroupMemberId GroupMemberRole + | APIBlockMemberForAll GroupId GroupMemberId Bool | APIRemoveMember GroupId GroupMemberId | APILeaveGroup GroupId | APIListMembers GroupId @@ -393,6 +394,7 @@ data ChatCommand | AddMember GroupName ContactName GroupMemberRole | JoinGroup GroupName | MemberRole GroupName ContactName GroupMemberRole + | BlockForAll GroupName ContactName Bool | RemoveMember GroupName ContactName | LeaveGroup GroupName | DeleteGroup GroupName @@ -630,11 +632,14 @@ data ChatResponse | CRJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember} | CRMemberRole {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole} | CRMemberRoleUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole} + | CRMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool} + | CRMemberBlockedForAllUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, blocked :: Bool} | CRConnectedToGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember, memberContact :: Maybe Contact} | CRDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember} | CRDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRLeftMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRUnknownMemberCreated {user :: User, groupInfo :: GroupInfo, forwardedByMember :: GroupMember, member :: GroupMember} + | CRUnknownMemberBlocked {user :: User, groupInfo :: GroupInfo, blockedByMember :: GroupMember, member :: GroupMember} | CRUnknownMemberAnnounced {user :: User, groupInfo :: GroupInfo, announcingMember :: GroupMember, unknownMember :: GroupMember, announcedMember :: GroupMember} | CRGroupEmpty {user :: User, groupInfo :: GroupInfo} | CRGroupRemoved {user :: User, groupInfo :: GroupInfo} @@ -1053,6 +1058,7 @@ data ChatErrorType | CEGroupDuplicateMemberId | CEGroupNotJoined {groupInfo :: GroupInfo} | CEGroupMemberNotActive + | CECantBlockMemberForSelf {groupInfo :: GroupInfo, member :: GroupMember, setShowMessages :: Bool} | CEGroupMemberUserRemoved | CEGroupMemberNotFound | CEGroupMemberIntroNotFound {contactName :: ContactName} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index ec6eb91a24..325c8a13ec 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -929,6 +929,7 @@ msgDeliveryStatusT' s = data CIDeleted (c :: ChatType) where CIDeleted :: Maybe UTCTime -> CIDeleted c CIBlocked :: Maybe UTCTime -> CIDeleted 'CTGroup + CIBlockedByAdmin :: Maybe UTCTime -> CIDeleted 'CTGroup CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup deriving instance Show (CIDeleted c) @@ -938,6 +939,7 @@ data ACIDeleted = forall c. ChatTypeI c => ACIDeleted (SChatType c) (CIDeleted c data JSONCIDeleted = JCIDDeleted {deletedTs :: Maybe UTCTime, chatType :: ChatType} | JCIDBlocked {deletedTs :: Maybe UTCTime} + | JCIBlockedByAdmin {deletedTs :: Maybe UTCTime} | JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember} deriving (Show) @@ -945,18 +947,21 @@ jsonCIDeleted :: forall d. ChatTypeI d => CIDeleted d -> JSONCIDeleted jsonCIDeleted = \case CIDeleted ts -> JCIDDeleted ts (toChatType $ chatTypeI @d) CIBlocked ts -> JCIDBlocked ts + CIBlockedByAdmin ts -> JCIBlockedByAdmin ts CIModerated ts m -> JCIDModerated ts m jsonACIDeleted :: JSONCIDeleted -> ACIDeleted jsonACIDeleted = \case JCIDDeleted ts cType -> case aChatType cType of ACT c -> ACIDeleted c $ CIDeleted ts JCIDBlocked ts -> ACIDeleted SCTGroup $ CIBlocked ts + JCIBlockedByAdmin ts -> ACIDeleted SCTGroup $ CIBlockedByAdmin ts JCIDModerated ts m -> ACIDeleted SCTGroup (CIModerated ts m) itemDeletedTs :: CIDeleted d -> Maybe UTCTime itemDeletedTs = \case CIDeleted ts -> ts CIBlocked ts -> ts + CIBlockedByAdmin ts -> ts CIModerated ts _ -> ts data ChatItemInfo = ChatItemInfo diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index cd448599d7..f0ce2d6274 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -138,6 +138,7 @@ data CIContent (d :: MsgDirection) where CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv CISndModerated :: CIContent 'MDSnd CIRcvModerated :: CIContent 'MDRcv + CIRcvBlocked :: CIContent 'MDRcv CIInvalidJSON :: Text -> CIContent d -- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API -- ! ^ Nested sum types also have to use different encodings for database and API @@ -177,6 +178,7 @@ ciRequiresAttention content = case msgDirection @d of RGEMemberConnected -> False RGEMemberLeft -> False RGEMemberRole {} -> False + RGEMemberBlocked {} -> False RGEUserRole _ -> True RGEMemberDeleted {} -> False RGEUserDeleted -> True @@ -192,6 +194,7 @@ ciRequiresAttention content = case msgDirection @d of CIRcvChatFeatureRejected _ -> True CIRcvGroupFeatureRejected _ -> True CIRcvModerated -> True + CIRcvBlocked -> False CIInvalidJSON _ -> False newtype DBMsgErrorType = DBME MsgErrorType @@ -246,6 +249,7 @@ ciContentToText = \case CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited" CISndModerated -> ciModeratedText CIRcvModerated -> ciModeratedText + CIRcvBlocked -> "blocked" CIInvalidJSON _ -> "invalid content JSON" ciGroupInvitationToText :: CIGroupInvitation -> GroupMemberRole -> Text @@ -263,6 +267,7 @@ rcvGroupEventToText = \case RGEMemberConnected -> "connected" RGEMemberLeft -> "left" RGEMemberRole _ p r -> "changed role of " <> profileToText p <> " to " <> safeDecodeUtf8 (strEncode r) + RGEMemberBlocked _ p blocked -> (if blocked then "blocked" else "unblocked") <> " " <> profileToText p RGEUserRole r -> "changed your role to " <> safeDecodeUtf8 (strEncode r) RGEMemberDeleted _ p -> "removed " <> profileToText p RGEUserDeleted -> "removed you" @@ -275,6 +280,7 @@ rcvGroupEventToText = \case sndGroupEventToText :: SndGroupEvent -> Text sndGroupEventToText = \case SGEMemberRole _ p r -> "changed role of " <> profileToText p <> " to " <> safeDecodeUtf8 (strEncode r) + SGEMemberBlocked _ p blocked -> (if blocked then "blocked" else "unblocked") <> " " <> profileToText p SGEUserRole r -> "changed role for yourself to " <> safeDecodeUtf8 (strEncode r) SGEMemberDeleted _ p -> "removed " <> profileToText p SGEUserLeft -> "left" @@ -375,6 +381,7 @@ data JSONCIContent | JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} | JCISndModerated | JCIRcvModerated + | JCIRcvBlocked | JCIInvalidJSON {direction :: MsgDirection, json :: Text} jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent @@ -404,6 +411,7 @@ jsonCIContent = \case CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature} CISndModerated -> JCISndModerated CIRcvModerated -> JCIRcvModerated + CIRcvBlocked -> JCIRcvBlocked CIInvalidJSON json -> JCIInvalidJSON (toMsgDirection $ msgDirection @d) json aciContentJSON :: JSONCIContent -> ACIContent @@ -433,6 +441,7 @@ aciContentJSON = \case JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature JCISndModerated -> ACIContent SMDSnd CISndModerated JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated + JCIRcvBlocked -> ACIContent SMDRcv CIRcvBlocked JCIInvalidJSON dir json -> case fromMsgDirection dir of AMsgDirection d -> ACIContent d $ CIInvalidJSON json @@ -463,6 +472,7 @@ data DBJSONCIContent | DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} | DBJCISndModerated | DBJCIRcvModerated + | DBJCIRcvBlocked | DBJCIInvalidJSON {direction :: MsgDirection, json :: Text} dbJsonCIContent :: forall d. MsgDirectionI d => CIContent d -> DBJSONCIContent @@ -492,6 +502,7 @@ dbJsonCIContent = \case CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature} CISndModerated -> DBJCISndModerated CIRcvModerated -> DBJCIRcvModerated + CIRcvBlocked -> DBJCIRcvBlocked CIInvalidJSON json -> DBJCIInvalidJSON (toMsgDirection $ msgDirection @d) json aciContentDBJSON :: DBJSONCIContent -> ACIContent @@ -521,6 +532,7 @@ aciContentDBJSON = \case DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature DBJCISndModerated -> ACIContent SMDSnd CISndModerated DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated + DBJCIRcvBlocked -> ACIContent SMDRcv CIRcvBlocked DBJCIInvalidJSON dir json -> case fromMsgDirection dir of AMsgDirection d -> ACIContent d $ CIInvalidJSON json @@ -613,4 +625,5 @@ toCIContentTag ciContent = case ciContent of CIRcvGroupFeatureRejected _ -> "rcvGroupFeatureRejected" CISndModerated -> "sndModerated" CIRcvModerated -> "rcvModerated" + CIRcvBlocked -> "rcvBlocked" CIInvalidJSON _ -> "invalidJSON" diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs index 3bb3ee836a..05417a2e14 100644 --- a/src/Simplex/Chat/Messages/CIContent/Events.hs +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -15,6 +15,7 @@ data RcvGroupEvent | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember | RGEMemberLeft -- CRLeftMember | RGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} + | RGEMemberBlocked {groupMemberId :: GroupMemberId, profile :: Profile, blocked :: Bool} -- CRMemberBlockedForAll | RGEUserRole {role :: GroupMemberRole} | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember | RGEUserDeleted -- CRDeletedMemberUser @@ -30,6 +31,7 @@ data RcvGroupEvent data SndGroupEvent = SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} + | SGEMemberBlocked {groupMemberId :: GroupMemberId, profile :: Profile, blocked :: Bool} -- CRMemberBlockedForAllUser | SGEUserRole {role :: GroupMemberRole} | SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember | SGEUserLeft -- CRLeftMemberUser diff --git a/src/Simplex/Chat/Migrations/M20240115_block_member_for_all.hs b/src/Simplex/Chat/Migrations/M20240115_block_member_for_all.hs new file mode 100644 index 0000000000..af2448e42c --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20240115_block_member_for_all.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20240115_block_member_for_all where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240115_block_member_for_all :: Query +m20240115_block_member_for_all = + [sql| +ALTER TABLE group_members ADD COLUMN member_restriction TEXT; +|] + +down_m20240115_block_member_for_all :: Query +down_m20240115_block_member_for_all = + [sql| +ALTER TABLE group_members DROP COLUMN member_restriction; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 0d048417ef..3a7f28e334 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -152,6 +152,7 @@ CREATE TABLE group_members( invited_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, peer_chat_min_version INTEGER NOT NULL DEFAULT 1, peer_chat_max_version INTEGER NOT NULL DEFAULT 1, + member_restriction TEXT, FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 0ad1afde67..c4423bfe6a 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -244,11 +244,12 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json XGrpLinkMem :: Profile -> ChatMsgEvent 'Json XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json - XGrpMemIntro :: MemberInfo -> ChatMsgEvent 'Json + XGrpMemIntro :: MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json + XGrpMemRestrict :: MemberId -> MemberRestrictions -> ChatMsgEvent 'Json XGrpMemCon :: MemberId -> ChatMsgEvent 'Json XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented XGrpMemDel :: MemberId -> ChatMsgEvent 'Json @@ -290,6 +291,7 @@ isForwardedGroupMsg ev = case ev of XInfo _ -> True XGrpMemNew _ -> True XGrpMemRole {} -> True + XGrpMemRestrict {} -> True XGrpMemDel _ -> True -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections) XGrpLeave -> True XGrpDel -> True -- TODO there should be a special logic - host should forward before deleting connections @@ -301,6 +303,14 @@ forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of SJson | isForwardedGroupMsg chatMsgEvent -> Just msg _ -> Nothing +-- applied after checking forwardedGroupMsg and building list of group members to forward to, see Chat +forwardedToGroupMembers :: forall e. MsgEncodingI e => [GroupMember] -> ChatMessage e -> [GroupMember] +forwardedToGroupMembers ms ChatMessage {chatMsgEvent} = case encoding @e of + SJson -> case chatMsgEvent of + XGrpMemRestrict mId _ -> filter (\GroupMember {memberId} -> memberId /= mId) ms + _ -> ms + _ -> [] + data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} deriving (Eq, Show) @@ -629,6 +639,7 @@ data CMEventTag (e :: MsgEncoding) where XGrpMemFwd_ :: CMEventTag 'Json XGrpMemInfo_ :: CMEventTag 'Json XGrpMemRole_ :: CMEventTag 'Json + XGrpMemRestrict_ :: CMEventTag 'Json XGrpMemCon_ :: CMEventTag 'Json XGrpMemConAll_ :: CMEventTag 'Json XGrpMemDel_ :: CMEventTag 'Json @@ -678,6 +689,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where XGrpMemFwd_ -> "x.grp.mem.fwd" XGrpMemInfo_ -> "x.grp.mem.info" XGrpMemRole_ -> "x.grp.mem.role" + XGrpMemRestrict_ -> "x.grp.mem.restrict" XGrpMemCon_ -> "x.grp.mem.con" XGrpMemConAll_ -> "x.grp.mem.con.all" XGrpMemDel_ -> "x.grp.mem.del" @@ -728,6 +740,7 @@ instance StrEncoding ACMEventTag where "x.grp.mem.fwd" -> XGrpMemFwd_ "x.grp.mem.info" -> XGrpMemInfo_ "x.grp.mem.role" -> XGrpMemRole_ + "x.grp.mem.restrict" -> XGrpMemRestrict_ "x.grp.mem.con" -> XGrpMemCon_ "x.grp.mem.con.all" -> XGrpMemConAll_ "x.grp.mem.del" -> XGrpMemDel_ @@ -769,11 +782,12 @@ toCMEventTag msg = case msg of XGrpLinkInv _ -> XGrpLinkInv_ XGrpLinkMem _ -> XGrpLinkMem_ XGrpMemNew _ -> XGrpMemNew_ - XGrpMemIntro _ -> XGrpMemIntro_ + XGrpMemIntro _ _ -> XGrpMemIntro_ XGrpMemInv _ _ -> XGrpMemInv_ XGrpMemFwd _ _ -> XGrpMemFwd_ XGrpMemInfo _ _ -> XGrpMemInfo_ XGrpMemRole _ _ -> XGrpMemRole_ + XGrpMemRestrict _ _ -> XGrpMemRestrict_ XGrpMemCon _ -> XGrpMemCon_ XGrpMemConAll _ -> XGrpMemConAll_ XGrpMemDel _ -> XGrpMemDel_ @@ -868,11 +882,12 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation" XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" - XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" + XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" <*> opt "memberRestrictions" XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro" XGrpMemFwd_ -> XGrpMemFwd <$> p "memberInfo" <*> p "memberIntro" XGrpMemInfo_ -> XGrpMemInfo <$> p "memberId" <*> p "profile" XGrpMemRole_ -> XGrpMemRole <$> p "memberId" <*> p "role" + XGrpMemRestrict_ -> XGrpMemRestrict <$> p "memberId" <*> p "memberRestrictions" XGrpMemCon_ -> XGrpMemCon <$> p "memberId" XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId" XGrpMemDel_ -> XGrpMemDel <$> p "memberId" @@ -928,11 +943,12 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv] XGrpLinkMem profile -> o ["profile" .= profile] XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] - XGrpMemIntro memInfo -> o ["memberInfo" .= memInfo] + XGrpMemIntro memInfo memRestrictions -> o $ ("memberRestrictions" .=? memRestrictions) ["memberInfo" .= memInfo] 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] + XGrpMemRestrict memId memRestrictions -> o ["memberId" .= memId, "memberRestrictions" .= memRestrictions] XGrpMemCon memId -> o ["memberId" .= memId] XGrpMemConAll memId -> o ["memberId" .= memId] XGrpMemDel memId -> o ["memberId" .= memId] diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 9f285549b6..fdc3703219 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -101,11 +101,11 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, - mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, -- from GroupMember - m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, + m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences FROM group_members m JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index d16812af22..189f95fdf0 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -98,6 +98,7 @@ module Simplex.Chat.Store.Groups deleteOldProbes, updateGroupSettings, updateGroupMemberSettings, + updateGroupMemberBlocked, getXGrpMemIntroContDirect, getXGrpMemIntroContGroup, getHostConnId, @@ -147,9 +148,9 @@ import UnliftIO.STM type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. GroupMemberRow -type GroupMemberRow = ((Int64, Int64, MemberId, Version, Version, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) +type GroupMemberRow = ((Int64, Int64, MemberId, Version, Version, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) -type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Version, Maybe Version, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) +type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Version, Maybe Version, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) toGroupInfo :: VersionRange -> Int64 -> GroupInfoRow -> GroupInfo toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. userMemberRow) = @@ -160,17 +161,18 @@ toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt} toGroupMember :: Int64 -> GroupMemberRow -> GroupMember -toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = +toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} memberSettings = GroupMemberSettings {showMessages} + blockedByAdmin = maybe False mrsBlocked memberRestriction_ invitedBy = toInvitedBy userContactId invitedById activeConn = Nothing memberChatVRange = JVersionRange $ fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer in GroupMember {..} toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember -toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just minVer, Just maxVer, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages) :. (invitedById, invitedByGroupMemberId, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = - Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) +toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just minVer, Just maxVer, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages, memberBlocked) :. (invitedById, invitedByGroupMemberId, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = + Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberBlocked) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) toMaybeGroupMember _ _ = Nothing createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO () @@ -268,11 +270,11 @@ getGroupAndMember db User {userId, userContactId} groupMemberId vr = g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, - mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, -- from GroupMember - m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, + m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, @@ -429,6 +431,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe memberCategory, memberStatus, memberSettings = defaultMemberSettings, + blockedByAdmin = False, invitedBy, invitedByGroupMemberId, localDisplayName, @@ -615,7 +618,7 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, - mu.group_member_id, g.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, + mu.group_member_id, g.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences FROM groups g JOIN group_profiles gp USING (group_profile_id) @@ -678,7 +681,7 @@ groupMemberQuery :: Query groupMemberQuery = [sql| SELECT - m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, + m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, @@ -797,6 +800,7 @@ createNewContactMember db gVar User {userId, userContactId} GroupInfo {groupId, memberCategory = GCInviteeMember, memberStatus = GSMemInvited, memberSettings = defaultMemberSettings, + blockedByAdmin = False, invitedBy = IBUser, invitedByGroupMemberId = Just invitedByGroupMemberId, localDisplayName, @@ -954,6 +958,7 @@ createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} m { memInfo, memCategory, memStatus, + memRestriction = Nothing, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Just $ groupMemberId' invitingMember, localDisplayName, @@ -981,6 +986,7 @@ createNewMember_ { memInfo = MemberInfo memberId memberRole memChatVRange memberProfile, memCategory = memberCategory, memStatus = memberStatus, + memRestriction, memInvitedBy = invitedBy, memInvitedByGroupMemberId, localDisplayName, @@ -995,12 +1001,12 @@ createNewMember_ db [sql| INSERT INTO group_members - (group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, + (group_id, member_id, member_role, member_category, member_status, member_restriction, invited_by, invited_by_group_member_id, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at, peer_chat_min_version, peer_chat_max_version) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ( (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, memInvitedByGroupMemberId) + ( (groupId, memberId, memberRole, memberCategory, memberStatus, memRestriction, invitedById, memInvitedByGroupMemberId) :. (userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) :. (minV, maxV) ) @@ -1014,6 +1020,7 @@ createNewMember_ memberCategory, memberStatus, memberSettings = defaultMemberSettings, + blockedByAdmin = maybe False mrsBlocked memRestriction, invitedBy, invitedByGroupMemberId = memInvitedByGroupMemberId, localDisplayName, @@ -1189,26 +1196,37 @@ getForwardInvitedMembers db user forwardMember highlyAvailable = do WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) |] -createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember -createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do - let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange - cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn - currentTs <- liftIO getCurrentTime - newMember <- case directConnIds of - Just (directCmdId, directAgentConnId) -> do - Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs subMode - liftIO $ setCommandConnId db user directCmdId directConnId - (localDisplayName, contactId, memProfileId) <- createContact_ db userId memberProfile "" (Just groupId) currentTs False - liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, directConnId) - pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Just contactId, memProfileId} - Nothing -> do - (localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs - pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} - liftIO $ do - member <- createNewMember_ db user gInfo newMember currentTs - conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs subMode - liftIO $ setCommandConnId db user groupCmdId groupConnId - pure (member :: GroupMember) {activeConn = Just conn} +createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember +createIntroReMember + db + user@User {userId} + gInfo@GroupInfo {groupId} + _host@GroupMember {memberContactId, activeConn} + memInfo@(MemberInfo _ _ memChatVRange memberProfile) + memRestrictions_ + (groupCmdId, groupAgentConnId) + directConnIds + customUserProfileId + subMode = do + let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange + cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn + memRestriction = restriction <$> memRestrictions_ + currentTs <- liftIO getCurrentTime + newMember <- case directConnIds of + Just (directCmdId, directAgentConnId) -> do + Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs subMode + liftIO $ setCommandConnId db user directCmdId directConnId + (localDisplayName, contactId, memProfileId) <- createContact_ db userId memberProfile "" (Just groupId) currentTs False + liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, directConnId) + pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Just contactId, memProfileId} + Nothing -> do + (localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs + pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} + liftIO $ do + member <- createNewMember_ db user gInfo newMember currentTs + conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs subMode + liftIO $ setCommandConnId db user groupCmdId groupConnId + pure (member :: GroupMember) {activeConn = Just conn} createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO () createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do @@ -1263,11 +1281,11 @@ getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, - mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, -- via GroupMember - m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, + m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, @@ -1358,7 +1376,7 @@ getGroupInfo db vr User {userId, userContactId} groupId = g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, - mu.member_status, mu.show_messages, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences FROM groups g JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id @@ -1768,6 +1786,18 @@ updateGroupMemberSettings db User {userId} gId gMemberId GroupMemberSettings {sh |] (showMessages, currentTs, userId, gId, gMemberId) +updateGroupMemberBlocked :: DB.Connection -> User -> GroupId -> GroupMemberId -> MemberRestrictionStatus -> IO () +updateGroupMemberBlocked db User {userId} gId gMemberId memberBlocked = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE group_members + SET member_restriction = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND group_member_id = ? + |] + (memberBlocked, currentTs, userId, gId, gMemberId) + getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do fmap join . maybeFirstRow toCont $ diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 2ece41666a..31373c17b8 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -52,8 +52,10 @@ module Simplex.Chat.Store.Messages updateGroupChatItem, deleteGroupChatItem, updateGroupChatItemModerated, + updateGroupCIBlockedByAdmin, markGroupChatItemDeleted, markGroupChatItemBlocked, + markGroupCIBlockedByAdmin, deleteLocalChatItem, updateDirectChatItemsRead, getDirectUnreadTimedItems, @@ -462,7 +464,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe SELECT i.chat_item_id, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, - m.member_status, m.show_messages, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences FROM group_members m JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) @@ -828,7 +830,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex ciMeta content status = let itemDeleted' = case itemDeleted of DBCINotDeleted -> Nothing - _ -> Just (CIDeleted @'CTLocal deletedTs) + _ -> Just (CIDeleted @CTLocal deletedTs) itemEdited' = fromMaybe False itemEdited in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt ciTimed :: Maybe CITimed @@ -1361,7 +1363,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT ciMeta content status = let itemDeleted' = case itemDeleted of DBCINotDeleted -> Nothing - _ -> Just (CIDeleted @'CTDirect deletedTs) + _ -> Just (CIDeleted @CTDirect deletedTs) itemEdited' = fromMaybe False itemEdited in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt ciTimed :: Maybe CITimed @@ -1413,7 +1415,8 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, let itemDeleted' = case itemDeleted of DBCINotDeleted -> Nothing DBCIBlocked -> Just (CIBlocked deletedTs) - _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) + DBCIBlockedByAdmin -> Just (CIBlockedByAdmin deletedTs) + _ -> Just (maybe (CIDeleted @CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) itemEdited' = fromMaybe False itemEdited in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt ciTimed :: Maybe CITimed @@ -1764,7 +1767,24 @@ updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMemb WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) - pure $ ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m), editable = False}, formattedText = Nothing} + pure $ ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False}, formattedText = Nothing} + +updateGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO (ChatItem 'CTGroup d) +updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = do + currentTs <- getCurrentTime + let itemId = chatItemId' ci + deleteChatItemMessages_ db itemId + deleteChatItemVersions_ db itemId + liftIO $ + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = ?, item_deleted_ts = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (DBCIBlockedByAdmin, deletedTs, currentTs, userId, groupId, itemId) + pure $ ci {meta = (meta ci) {itemDeleted = Just (CIBlockedByAdmin $ Just deletedTs), editable = False}, formattedText = Nothing} pattern DBCINotDeleted :: Int pattern DBCINotDeleted = 0 @@ -1775,13 +1795,16 @@ pattern DBCIDeleted = 1 pattern DBCIBlocked :: Int pattern DBCIBlocked = 2 +pattern DBCIBlockedByAdmin :: Int +pattern DBCIBlockedByAdmin = 3 + markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d) markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} msgId byGroupMember_ deletedTs = do currentTs <- liftIO getCurrentTime let itemId = chatItemId' ci (deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m) - _ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs)) + _ -> (Nothing, Just $ CIDeleted @CTGroup (Just deletedTs)) insertChatItemMessage_ db itemId msgId currentTs DB.execute db @@ -1806,6 +1829,19 @@ markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} (DBCIBlocked, deletedTs, deletedTs, userId, groupId, chatItemId' ci) pure ci {meta = meta {itemDeleted = Just $ CIBlocked $ Just deletedTs}} +markGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv) +markGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do + deletedTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = ?, item_deleted_ts = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (DBCIBlockedByAdmin, deletedTs, deletedTs, userId, groupId, chatItemId' ci) + pure ci {meta = meta {itemDeleted = Just $ CIBlockedByAdmin $ Just deletedTs}} + getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do itemId <- @@ -1864,17 +1900,17 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do i.forwarded_by_group_member_id, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, - m.member_status, m.show_messages, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, -- quoted ChatItem ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, -- quoted GroupMember rm.group_member_id, rm.group_id, rm.member_id, rm.peer_chat_min_version, rm.peer_chat_max_version, rm.member_role, rm.member_category, - rm.member_status, rm.show_messages, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, + rm.member_status, rm.show_messages, rm.member_restriction, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, -- deleted by GroupMember dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.peer_chat_min_version, dbm.peer_chat_max_version, dbm.member_role, dbm.member_category, - dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, + dbm.member_status, dbm.show_messages, dbm.member_restriction, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences FROM chat_items i LEFT JOIN files f ON f.chat_item_id = i.chat_item_id diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index ffd5dbdf57..f9513dcc2a 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -96,6 +96,7 @@ import Simplex.Chat.Migrations.M20231214_item_content_tag import Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries import Simplex.Chat.Migrations.M20240102_note_folders import Simplex.Chat.Migrations.M20240104_members_profile_update +import Simplex.Chat.Migrations.M20240115_block_member_for_all import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -191,7 +192,8 @@ schemaMigrations = ("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag), ("20231215_recreate_msg_deliveries", m20231215_recreate_msg_deliveries, Just down_m20231215_recreate_msg_deliveries), ("20240102_note_folders", m20240102_note_folders, Just down_m20240102_note_folders), - ("20240104_members_profile_update", m20240104_members_profile_update, Just down_m20240104_members_profile_update) + ("20240104_members_profile_update", m20240104_members_profile_update, Just down_m20240104_members_profile_update), + ("20240115_block_member_for_all", m20240115_block_member_for_all, Just down_m20240115_block_member_for_all) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 417dfcb56c..e65e1a916f 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -35,6 +35,7 @@ import Data.Int (Int64) import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Typeable (Typeable) import Database.SQLite.Simple (ResultError (..), SQLData (..)) @@ -50,7 +51,7 @@ import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Version class IsContact a where @@ -596,9 +597,55 @@ data MemberInfo = MemberInfo memberInfo :: GroupMember -> MemberInfo memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} = - MemberInfo memberId memberRole cvr (redactedMemberProfile $ fromLocalProfile memberProfile) - where - cvr = ChatVersionRange . fromJVersionRange . peerChatVRange <$> activeConn + MemberInfo + { memberId, + memberRole, + v = ChatVersionRange . fromJVersionRange . peerChatVRange <$> activeConn, + profile = redactedMemberProfile $ fromLocalProfile memberProfile + } + +data MemberRestrictionStatus + = MRSBlocked + | MRSUnrestricted + | MRSUnknown Text + deriving (Eq, Show) + +instance FromField MemberRestrictionStatus where fromField = fromBlobField_ strDecode + +instance ToField MemberRestrictionStatus where toField = toField . strEncode + +instance StrEncoding MemberRestrictionStatus where + strEncode = \case + MRSBlocked -> "blocked" + MRSUnrestricted -> "unrestricted" + MRSUnknown tag -> encodeUtf8 tag + strDecode s = Right $ case s of + "blocked" -> MRSBlocked + "unrestricted" -> MRSUnrestricted + tag -> MRSUnknown $ safeDecodeUtf8 tag + strP = strDecode <$?> A.takeByteString + +instance FromJSON MemberRestrictionStatus where + parseJSON = strParseJSON "MemberRestrictionStatus" + +instance ToJSON MemberRestrictionStatus where + toJSON = strToJSON + toEncoding = strToJEncoding + +mrsBlocked :: MemberRestrictionStatus -> Bool +mrsBlocked = \case + MRSBlocked -> True + _ -> False + +data MemberRestrictions = MemberRestrictions + { restriction :: MemberRestrictionStatus + } + deriving (Eq, Show) + +memberRestrictions :: GroupMember -> Maybe MemberRestrictions +memberRestrictions m + | blockedByAdmin m = Just MemberRestrictions {restriction = MRSBlocked} + | otherwise = Nothing data ReceivedGroupInvitation = ReceivedGroupInvitation { fromMember :: GroupMember, @@ -619,6 +666,7 @@ data GroupMember = GroupMember memberCategory :: GroupMemberCategory, memberStatus :: GroupMemberStatus, memberSettings :: GroupMemberSettings, + blockedByAdmin :: Bool, invitedBy :: InvitedBy, invitedByGroupMemberId :: Maybe GroupMemberId, localDisplayName :: ContactName, @@ -679,6 +727,7 @@ data NewGroupMember = NewGroupMember { memInfo :: MemberInfo, memCategory :: GroupMemberCategory, memStatus :: GroupMemberStatus, + memRestriction :: Maybe MemberRestrictionStatus, memInvitedBy :: InvitedBy, memInvitedByGroupMemberId :: Maybe GroupMemberId, localDisplayName :: ContactName, @@ -1641,6 +1690,8 @@ $(JQ.deriveJSON defaultJSON ''IntroInvitation) $(JQ.deriveJSON defaultJSON ''MemberInfo) +$(JQ.deriveJSON defaultJSON ''MemberRestrictions) + $(JQ.deriveJSON defaultJSON ''GroupMemberRef) $(JQ.deriveJSON defaultJSON ''FileDescr) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4f6e774a16..05c90696b4 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -179,6 +179,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRUserDeletedMember u g m -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"] CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g CRUnknownMemberCreated u g fwdM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember fwdM <> " forwarded a message from an unknown member, creating unknown member record " <> ttyMember um] + CRUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um] CRUnknownMemberAnnounced u g _ um m -> ttyUser u [ttyGroup' g <> ": unknown member " <> ttyMember um <> " updated to " <> ttyMember m] CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"] CRRcvFileDescrReady _ _ -> [] @@ -243,6 +244,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRConnectedToGroupMember u g m _ -> ttyUser u [ttyGroup' g <> ": " <> connectedMember m <> " is connected"] CRMemberRole u g by m r r' -> ttyUser u $ viewMemberRoleChanged g by m r r' CRMemberRoleUser u g m r r' -> ttyUser u $ viewMemberRoleUserChanged g m r r' + CRMemberBlockedForAll u g by m blocked -> ttyUser u $ viewMemberBlockedForAll g by m blocked + CRMemberBlockedForAllUser u g m blocked -> ttyUser u $ viewMemberBlockedForAllUser g m blocked CRDeletedMemberUser u g by -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g CRDeletedMember u g by m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"] CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"] @@ -436,21 +439,16 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString] unmuted' u chat chatDir mention s | chatDirNtf u chat chatDir mention = s + | testView = map (<> " ") s | otherwise = [] userNtf :: User -> Bool userNtf User {showNtfs, activeUser} = showNtfs || activeUser -chatNtf :: User -> ChatInfo c -> Bool -> Bool -chatNtf user cInfo mention = case cInfo of - DirectChat ct -> contactNtf user ct mention - GroupChat g -> groupNtf user g mention - _ -> False - chatDirNtf :: User -> ChatInfo c -> CIDirection c d -> Bool -> Bool chatDirNtf user cInfo chatDir mention = case (cInfo, chatDir) of (DirectChat ct, CIDirectRcv) -> contactNtf user ct mention - (GroupChat g, CIGroupRcv m) -> groupNtf user g mention && showMessages (memberSettings m) + (GroupChat g, CIGroupRcv m) -> groupNtf user g mention && not (blockedByAdmin m) && showMessages (memberSettings m) _ -> True contactNtf :: User -> Contact -> Bool -> Bool @@ -473,6 +471,7 @@ chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_ CIModerated _ m -> markedDeleted content <> byMember m CIDeleted _ -> markedDeleted content CIBlocked _ -> "blocked" + CIBlockedByAdmin _ -> "blocked by admin" markedDeleted = \case CISndModerated -> "deleted" CIRcvModerated -> "deleted" @@ -555,6 +554,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta CIRcvGroupInvitation {} -> showRcvItemProhibited from CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False + CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False _ -> showRcvItem from where from = ttyFromGroup g m @@ -978,6 +978,14 @@ viewMemberRoleUserChanged g@GroupInfo {membership} m r r' where view s = [ttyGroup' g <> ": you changed " <> s <> " from " <> showRole r <> " to " <> showRole r'] +viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> [StyledString] +viewMemberBlockedForAll g by m blocked = + [ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m] + +viewMemberBlockedForAllUser :: GroupInfo -> GroupMember -> Bool -> [StyledString] +viewMemberBlockedForAllUser g m blocked = + [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m] + showRole :: GroupMemberRole -> StyledString showRole = plain . strEncode @@ -1003,8 +1011,9 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt GSMemCreator -> ["created group"] _ -> [] muted m - | showMessages (memberSettings m) = [] - | otherwise = ["blocked"] + | blockedByAdmin m = ["blocked by admin"] + | not (showMessages $ memberSettings m) = ["blocked"] + | otherwise = [] viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString] viewContactConnected ct userIncognitoProfile testView = @@ -1847,6 +1856,13 @@ viewChatError logLevel testView = \case CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"] CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> viewGroupName g)] CEGroupMemberNotActive -> ["your group connection is not active yet, try later"] + CECantBlockMemberForSelf g m showMsgs -> + [ "admins or above can't block member for self, use " + <> highlight + ( (if showMsgs then "/unblock for all" else "/block for all") + <> (" #" <> viewGroupName g <> " " <> viewMemberName m) + ) + ] CEGroupMemberUserRemoved -> ["you are no longer a member of the group"] CEGroupMemberNotFound -> ["group doesn't have this member"] CEGroupMemberIntroNotFound c -> ["group member intro not found for " <> ttyContact c] diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 3eb4afcb07..8e7f8536ee 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -1180,7 +1180,7 @@ testMuteContact = bob ##> "/mute @alice" bob <## "ok" alice #> "@bob hi" - (bob hi " bob ##> "/contacts" bob <## "alice (Alice) (muted, you can /unmute @alice)" bob ##> "/unmute @alice" @@ -1204,7 +1204,7 @@ testMuteGroup = bob <## "ok" alice #> "#team hi" concurrently_ - (bob hi ") (cath <# "#team alice> hi") bob #> "#team hello" concurrently_ @@ -1214,7 +1214,9 @@ testMuteGroup = cath <# "#team > bob hello" cath <## " hello too!" concurrentlyN_ - [ (bob > bob hello " + bob <## " hello too! ", do alice <# "#team cath> > bob hello" alice <## " hello too!" @@ -1236,7 +1238,9 @@ testMuteGroup = alice <# "#team > cath hello too!" alice <## " hey cath!" concurrentlyN_ - [ (bob > cath hello too! " + bob <## " hey cath! ", do cath <# "#team alice> > cath hello too!" cath <## " hey cath!" @@ -1245,20 +1249,32 @@ testMuteGroup = bob <## "#team (3 members, mentions only, you can /unmute #team)" bob ##> "/unmute #team" bob <## "ok" + + threadDelay 1000000 + alice #> "#team hi again" concurrently_ (bob <# "#team alice> hi again") (cath <# "#team alice> hi again") bob ##> "/block #team alice" + bob <## "admins or above can't block member for self, use /block for all #team alice" + -- can bypass with api + bob ##> "/_member settings #1 1 {\"showMessages\": false}" bob <## "ok" bob ##> "/ms team" bob <## "bob (Bob): admin, you, connected" bob <## "alice (Alice): owner, host, connected, blocked" bob <## "cath (Catherine): admin, connected" + + threadDelay 1000000 + alice #> "#team test 1" concurrently_ - (bob test 1 [blocked] ") (cath <# "#team alice> test 1") + + threadDelay 1000000 + cath #> "#team test 2" concurrently_ (bob <# "#team cath> test 2") @@ -1269,6 +1285,9 @@ testMuteGroup = bob <# "#team cath> test 2" threadDelay 1000000 bob ##> "/unblock #team alice" + bob <## "admins or above can't block member for self, use /unblock for all #team alice" + -- can bypass with api + bob ##> "/_member settings #1 1 {\"showMessages\": true}" bob <## "ok" bob ##> "/ms team" bob <## "bob (Bob): admin, you, connected" diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 349db6f7f8..51a5b352a7 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -141,6 +141,12 @@ chatGroupTests = do it "member contact is deleted silently, then considered disabled" testMembershipProfileUpdateContactDisabled it "profile update without change is ignored" testMembershipProfileUpdateNoChangeIgnored it "change of profile contact link is ignored" testMembershipProfileUpdateContactLinkIgnored + describe "block member for all" $ do + it "messages are marked blocked" testBlockForAllMarkedBlocked + it "messages are fully deleted" testBlockForAllFullDelete + it "another admin can unblock" testBlockForAllAnotherAdminUnblocks + it "member was blocked before joining group" testBlockForAllBeforeJoining + it "can't repeat block, unblock" testBlockForAllCantRepeat where _0 = supportedChatVRange -- don't create direct connections _1 = groupCreateDirectVRange @@ -5056,7 +5062,8 @@ testGroupHistoryDeletedMessage = testGroupHistoryDisappearingMessage :: HasCallStack => FilePath -> IO () testGroupHistoryDisappearingMessage = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + -- \alice bob cath -> do -- revert when test is stable + \a b c -> withTestOutput a $ \alice -> withTestOutput b $ \bob -> withTestOutput c $ \cath -> do createGroup2 "team" alice bob threadDelay 1000000 @@ -5067,12 +5074,12 @@ testGroupHistoryDisappearingMessage = threadDelay 1000000 -- 3 seconds so that messages 2 and 3 are not deleted for alice before sending history to cath - alice ##> "/set disappear #team on 3" + alice ##> "/set disappear #team on 4" alice <## "updated group preferences:" - alice <## "Disappearing messages: on (3 sec)" + alice <## "Disappearing messages: on (4 sec)" bob <## "alice updated group #team:" bob <## "updated group preferences:" - bob <## "Disappearing messages: on (3 sec)" + bob <## "Disappearing messages: on (4 sec)" bob #> "#team 2" alice <# "#team bob> 2" @@ -5117,15 +5124,18 @@ testGroupHistoryDisappearingMessage = r1 `shouldContain` [(0, "1"), (0, "2"), (0, "3"), (0, "4")] concurrentlyN_ - [ do - alice <## "timed message deleted: 2" - alice <## "timed message deleted: 3", - do - bob <## "timed message deleted: 2" - bob <## "timed message deleted: 3", - do - cath <## "timed message deleted: 2" - cath <## "timed message deleted: 3" + [ alice + <### [ "timed message deleted: 2", + "timed message deleted: 3" + ], + bob + <### [ "timed message deleted: 2", + "timed message deleted: 3" + ], + cath + <### [ "timed message deleted: 2", + "timed message deleted: 3" + ] ] cath ##> "/_get chat #1 count=100" @@ -5695,3 +5705,312 @@ testMembershipProfileUpdateContactLinkIgnored = bob <##. "sending messages via" bob <## "connection not verified, use /code command to see security code" bob <## currentChatVRangeInfo + +testBlockForAllMarkedBlocked :: HasCallStack => FilePath -> IO () +testBlockForAllMarkedBlocked = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + threadDelay 1000000 + + bob #> "#team 1" + [alice, cath] *<# "#team bob> 1" + + threadDelay 1000000 + + alice ##> "/block for all #team bob" + alice <## "#team: you blocked bob" + cath <## "#team: alice blocked bob" + bob "/ms team" + alice + <### [ "alice (Alice): owner, you, created group", + "bob (Bob): admin, invited, connected, blocked by admin", + "cath (Catherine): admin, invited, connected" + ] + + cath ##> "/ms team" + cath + <### [ "cath (Catherine): admin, you, connected", + "alice (Alice): owner, host, connected", + "bob (Bob): admin, connected, blocked by admin" + ] + + bob ##> "/ms team" + bob + <### [ "bob (Bob): admin, you, connected", + "alice (Alice): owner, host, connected", + "cath (Catherine): admin, connected" + ] + + threadDelay 1000000 + + bob #> "#team 2" + alice <# "#team bob> 2 [blocked by admin] " + cath <# "#team bob> 2 [blocked by admin] " + + threadDelay 1000000 + + bob #> "#team 3" + alice <# "#team bob> 3 [blocked by admin] " + cath <# "#team bob> 3 [blocked by admin] " + + threadDelay 1000000 + + alice ##> "/unblock for all #team bob" + alice <## "#team: you unblocked bob" + cath <## "#team: alice unblocked bob" + bob "#team 4" + [alice, cath] *<# "#team bob> 4" + + alice + #$> ( "/_get chat #1 count=6", + chat, + [ (0, "1"), + (1, "blocked bob (Bob)"), + (0, "2 [blocked by admin]"), + (0, "3 [blocked by admin]"), + (1, "unblocked bob (Bob)"), + (0, "4") + ] + ) + cath + #$> ( "/_get chat #1 count=6", + chat, + [ (0, "1"), + (0, "blocked bob (Bob)"), + (0, "2 [blocked by admin]"), + (0, "3 [blocked by admin]"), + (0, "unblocked bob (Bob)"), + (0, "4") + ] + ) + bob #$> ("/_get chat #1 count=4", chat, [(1, "1"), (1, "2"), (1, "3"), (1, "4")]) + +testBlockForAllFullDelete :: HasCallStack => FilePath -> IO () +testBlockForAllFullDelete = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice ##> "/set delete #team on" + alice <## "updated group preferences:" + alice <## "Full deletion: on" + concurrentlyN_ + [ do + bob <## "alice updated group #team:" + bob <## "updated group preferences:" + bob <## "Full deletion: on", + do + cath <## "alice updated group #team:" + cath <## "updated group preferences:" + cath <## "Full deletion: on" + ] + + threadDelay 1000000 + + bob #> "#team 1" + [alice, cath] *<# "#team bob> 1" + + threadDelay 1000000 + + alice ##> "/block for all #team bob" + alice <## "#team: you blocked bob" + cath <## "#team: alice blocked bob" + bob "#team 2" + alice <# "#team bob> blocked [blocked by admin] " + cath <# "#team bob> blocked [blocked by admin] " + + threadDelay 1000000 + + bob #> "#team 3" + alice <# "#team bob> blocked [blocked by admin] " + cath <# "#team bob> blocked [blocked by admin] " + + threadDelay 1000000 + + alice ##> "/unblock for all #team bob" + alice <## "#team: you unblocked bob" + cath <## "#team: alice unblocked bob" + bob "#team 4" + [alice, cath] *<# "#team bob> 4" + + alice + #$> ( "/_get chat #1 count=6", + chat, + [ (0, "1"), + (1, "blocked bob (Bob)"), + (0, "blocked [blocked by admin]"), + (0, "blocked [blocked by admin]"), + (1, "unblocked bob (Bob)"), + (0, "4") + ] + ) + cath + #$> ( "/_get chat #1 count=6", + chat, + [ (0, "1"), + (0, "blocked bob (Bob)"), + (0, "blocked [blocked by admin]"), + (0, "blocked [blocked by admin]"), + (0, "unblocked bob (Bob)"), + (0, "4") + ] + ) + bob #$> ("/_get chat #1 count=4", chat, [(1, "1"), (1, "2"), (1, "3"), (1, "4")]) + +testBlockForAllAnotherAdminUnblocks :: HasCallStack => FilePath -> IO () +testBlockForAllAnotherAdminUnblocks = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + bob #> "#team 1" + [alice, cath] *<# "#team bob> 1" + + alice ##> "/block for all #team bob" + alice <## "#team: you blocked bob" + cath <## "#team: alice blocked bob" + bob "#team 2" + alice <# "#team bob> 2 [blocked by admin] " + cath <# "#team bob> 2 [blocked by admin] " + + cath ##> "/unblock for all #team bob" + cath <## "#team: you unblocked bob" + alice <## "#team: cath unblocked bob" + bob "#team 3" + [alice, cath] *<# "#team bob> 3" + + bob #$> ("/_get chat #1 count=3", chat, [(1, "1"), (1, "2"), (1, "3")]) + +testBlockForAllBeforeJoining :: HasCallStack => FilePath -> IO () +testBlockForAllBeforeJoining = + testChat4 aliceProfile bobProfile cathProfile danProfile $ + \alice bob cath dan -> do + createGroup3 "team" alice bob cath + + bob #> "#team 1" + [alice, cath] *<# "#team bob> 1" + + alice ##> "/block for all #team bob" + alice <## "#team: you blocked bob" + cath <## "#team: alice blocked bob" + bob "#team 2" + [alice, cath] *<# "#team bob> 2 [blocked by admin] " + + connectUsers alice dan + addMember "team" alice dan GRAdmin + dan ##> "/j team" + concurrentlyN_ + [ alice <## "#team: dan joined the group", + do + dan <## "#team: you joined the group" + dan + <### [ "#team: member bob (Bob) is connected", + "#team: member cath (Catherine) is connected" + ], + aliceAddedDan bob, + aliceAddedDan cath + ] + + threadDelay 1000000 + + bob #> "#team 3" + [alice, cath, dan] *<# "#team bob> 3 [blocked by admin] " + + threadDelay 1000000 + + bob #> "#team 4" + [alice, cath, dan] *<# "#team bob> 4 [blocked by admin] " + + threadDelay 1000000 + + alice ##> "/unblock for all #team bob" + alice <## "#team: you unblocked bob" + cath <## "#team: alice unblocked bob" + dan <## "#team: alice unblocked bob" + bob "#team 5" + [alice, cath, dan] *<# "#team bob> 5" + + dan ##> "/_get chat #1 count=100" + r <- chat <$> getTermLine dan + r `shouldContain` [(0, "3 [blocked by admin]"), (0, "4 [blocked by admin]"), (0, "unblocked bob (Bob)"), (0, "5")] + r `shouldNotContain` [(0, "1")] + r `shouldNotContain` [(0, "1 [blocked by admin]")] + r `shouldNotContain` [(0, "2")] + r `shouldNotContain` [(0, "2 [blocked by admin]")] + where + aliceAddedDan :: HasCallStack => TestCC -> IO () + aliceAddedDan cc = do + cc <## "#team: alice added dan (Daniel) to the group (connecting...)" + cc <## "#team: new member dan is connected" + +testBlockForAllCantRepeat :: HasCallStack => FilePath -> IO () +testBlockForAllCantRepeat = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice ##> "/unblock for all #team bob" + alice <## "bad chat command: already unblocked" + + cath ##> "/unblock for all #team bob" + cath <## "bad chat command: already unblocked" + + bob #> "#team 1" + [alice, cath] *<# "#team bob> 1" + + alice ##> "/block for all #team bob" + alice <## "#team: you blocked bob" + cath <## "#team: alice blocked bob" + bob "/block for all #team bob" + alice <## "bad chat command: already blocked" + + cath ##> "/block for all #team bob" + cath <## "bad chat command: already blocked" + + bob #> "#team 2" + alice <# "#team bob> 2 [blocked by admin] " + cath <# "#team bob> 2 [blocked by admin] " + + cath ##> "/unblock for all #team bob" + cath <## "#team: you unblocked bob" + alice <## "#team: cath unblocked bob" + bob "/unblock for all #team bob" + alice <## "bad chat command: already unblocked" + + cath ##> "/unblock for all #team bob" + cath <## "bad chat command: already unblocked" + + bob #> "#team 3" + [alice, cath] *<# "#team bob> 3" + + bob #$> ("/_get chat #1 count=3", chat, [(1, "1"), (1, "2"), (1, "3")]) diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 3ab7cf1a97..783f7fb344 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -243,10 +243,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} it "x.grp.mem.intro" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} Nothing it "x.grp.mem.intro with member chat version range" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-7\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} Nothing + it "x.grp.mem.intro with member restrictions" $ + "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberRestrictions\":{\"restriction\":\"blocked\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} (Just MemberRestrictions {restriction = MRSBlocked}) it "x.grp.mem.inv" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}" #==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}