From f39002a146d2c7b65b4355d5c4546823f17e18ad Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Wed, 21 Oct 2026 13:48:53 +0000 Subject: [PATCH] update code --- bots/src/API/Docs/Commands.hs | 2 +- bots/src/API/Docs/Types.hs | 2 +- docs/protocol/simplex-chat.md | 13 +- docs/protocol/simplex-chat.schema.json | 28 +- src/Simplex/Chat/Controller.hs | 13 +- src/Simplex/Chat/Library/Commands.hs | 239 +++++++++------ src/Simplex/Chat/Library/Subscriber.hs | 154 ++++++---- src/Simplex/Chat/Protocol.hs | 24 +- src/Simplex/Chat/Store/Connections.hs | 4 +- src/Simplex/Chat/Store/Groups.hs | 48 ++- src/Simplex/Chat/Store/Messages.hs | 12 +- .../Migrations/M20261020_link_notices.hs | 11 +- .../Migrations/M20261020_link_notices.hs | 11 +- src/Simplex/Chat/Store/Shared.hs | 42 +-- src/Simplex/Chat/Types.hs | 11 +- src/Simplex/Chat/View.hs | 14 +- tests/ChatTests/Direct.hs | 38 ++- tests/ChatTests/Groups.hs | 288 +++++++++++++++--- tests/ChatTests/Profiles.hs | 77 ++--- tests/ChatTests/Utils.hs | 13 +- tests/ProtocolTests.hs | 43 +-- 21 files changed, 752 insertions(+), 335 deletions(-) diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index 91bd4fa792..5e357b532b 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -123,7 +123,7 @@ chatCommandsDocsData = ("APIJoinGroup", ["enableNtfs"], "Join group.", ["CRUserAcceptedGroupSent", "CRChatCmdError"], [], Just UNInteractive, "/_join #" <> Param "groupId"), ("APIAcceptMember", [], "Accept group member. Requires Admin role.", ["CRMemberAccepted", "CRChatCmdError"], [TD "CEGroupMemberNotActive" "Member is not connected yet"], Just UNBackground, "/_accept member #" <> Param "groupId" <> " " <> Param "groupMemberId" <> " " <> Param "memberRole"), ("APIMembersRole", [], "Set members role. Requires Admin role.", ["CRMembersRoleUser", "CRChatCmdError"], [], Just UNBackground, "/_member role #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> " " <> Param "memberRole"), - ("APIBlockMembersForAll", [], "Block members. Requires Moderator role.", ["CRMembersBlockedForAllUser", "CRChatCmdError"], [], Just UNBackground, "/_block #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> OnOffParam "blocked" "blocked" Nothing), + ("APIBlockMembersForAll", [], "Block members. Requires Moderator role.", ["CRMembersBlockedForAllUser", "CRChatCmdError"], [], Just UNBackground, "/_block #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> OnOffParam "blocked" "blocked" Nothing <> Optional "" (" ttl=" <> Param "$0") "ttl"), ("APIRemoveMembers", [], "Remove members. Requires Admin role.", ["CRUserDeletedMembers", "CRChatCmdError"], ["CEGroupMemberNotFound"], Just UNBackground, "/_remove #" <> Param "groupId" <> " " <> Join ',' "groupMemberIds" <> OnOffParam "messages" "withMessages" (Just False) <> Optional "" (" notice=" <> Json "$0") "notice"), ("APILeaveGroup", [], "Leave group.", ["CRLeftMemberUser", "CRChatCmdError"], [], Just UNBackground, "/_leave #" <> Param "groupId"), ("APIListMembers", [], "Get group members.", ["CRGroupMembers", "CRChatCmdError"], [], Nothing, "/_members #" <> Param "groupId"), diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index 7ec28abf1c..504ee04509 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -229,7 +229,7 @@ chatTypesDocsData = (sti @BusinessChatInfo, STRecord, "", [], "", ""), (sti @BusinessChatType, STEnum, "BC", [], "", ""), (sti @ChatBotCommand, STUnion, "CBC", [], "", ""), - (sti @ChatDeleteMode, STUnion, "CDM", [], Param "type" <> Choice "self" [("messages", "")] (OnOffParam "notify" "notify" (Just True)), ""), + (sti @ChatDeleteMode, STUnion, "CDM", [], Param "type" <> Choice "self" [("messages", ""), ("archive", "")] (OnOffParam "notify" "notify" (Just True)), ""), (sti @ChatError, STUnion, "Chat", ["ChatErrorDatabase", "ChatErrorRemoteHost", "ChatErrorRemoteCtrl"], "", ""), (sti @ChatErrorType, STUnion, "CE", ["CEContactNotFound", "CEServerProtocol", "CECallState", "CEInvalidChatMessage"], "", ""), (sti @BadgeStatus, STEnum, "BS", [], "", ""), diff --git a/docs/protocol/simplex-chat.md b/docs/protocol/simplex-chat.md index 8b5ba02ac4..c27d69ad7c 100644 --- a/docs/protocol/simplex-chat.md +++ b/docs/protocol/simplex-chat.md @@ -252,7 +252,7 @@ Currently members can have one of four roles - `owner`, `admin`, `member` and `o `x.grp.mem.role` message is sent to update group member role - it is sent to all members by the member who updated the role of the member referenced in this message. This message MUST only be sent by members with `admin` or `owner` role. Receiving clients MUST ignore this message if it is received from member with role less than `admin`. -`x.grp.mem.restrict` message is sent to group members to communicate group member restrictions, such as member being blocked for sending messages. +`x.grp.mem.restrict` message is sent to group members to communicate group member restrictions, such as member being blocked for sending messages. The restrictions MAY include `expiresAt` time set by the sender, when the block ends. A block also ends when the member is unblocked, and it does not apply to a member who leaves and joins again. When a block with `expiresAt` ends, the client of the member who set it sends `x.grp.mem.restrict` with `unrestricted` restriction and `expiresAt` of the ended block. Clients with chat protocol version 23 or later ignore this message, as they end the block at `expiresAt`. `x.grp.mem.con` message is sent by members connecting inside group to inviting member, to notify the inviting member they have completed the connection and no longer require forwarding messages between them. @@ -260,7 +260,7 @@ Currently members can have one of four roles - `owner`, `admin`, `member` and `o `x.grp.leave` message is sent to all members by the member leaving the group. If the only group `owner` leaves the group, it will not be possible to delete it with `x.grp.del` message - but all members can still leave the group with `x.grp.leave` message and then delete a local copy of the group. -`x.grp.del` message is sent to all members by the member who deletes the group. Clients who received this message SHOULD keep a local copy of the deleted group, until it is deleted by the user. This message MUST only be sent by members with `owner` role. Receiving clients MUST ignore this message if it is received from member other than with `owner` role. Receiving clients apply optional `notice` property to the business address of a deleted business chat (see [Link notices](#link-notices)). +`x.grp.del` message is sent to all members by the member who deletes the group. Clients who received this message SHOULD keep a local copy of the deleted group, until it is deleted by the user. This message MUST only be sent by members with `owner` role. Receiving clients MUST ignore this message if it is received from member other than with `owner` role. `x.grp.info` message is sent to all members by the member who updated group profile. Only group owners can update group profiles. Clients MAY implement some conflict resolution strategy - it is currently not implemented by SimpleX Chat client. This message MUST only be sent by members with `owner` role. Receiving clients MUST ignore this message if it is received from member other than with `owner` role. @@ -270,9 +270,14 @@ Currently members can have one of four roles - `owner`, `admin`, `member` and `o ### Link notices -`x.grp.mem.del`, `x.grp.del` and `x.direct.del` messages MAY include `notice` property with optional `ttl` (seconds) and optional `reason` (`spam`, `content`, `community`, `profile` or `other`). The receiving client stores the notice for the link it joined or connected through, as recorded in its own group or contact record, and does not connect via this link until the notice expires. The notice expires `ttl` seconds after the server timestamp of the message; a notice without `ttl` does not expire. A new notice for the same link replaces the previous one. Clients MUST ignore a malformed notice and process the message. +`x.grp.mem.del` and `x.direct.del` messages MAY include `notice` property with optional `ttl` (seconds). The receiving client stores the notice for the link it joined or connected through, as recorded in its own group or contact record, and does not connect via this link until the notice expires. The notice expires `ttl` seconds after the server timestamp of the message; a notice without `ttl` does not expire. A new notice for the same link replaces the previous one. Clients MUST ignore a malformed notice and process the message. -When `x.direct.del` message has `"silent": true` property, the receiving client stores the notice and does not delete the contact. Clients send it when the contact is deleted without notification, only to contacts with chat protocol version 23 or later. +`x.grp.mem.del` and `x.direct.del` messages MAY include `"silent": true` property: +- the client of the deleted contact does not delete the contact and shows nothing. +- the client of the removed member shows nothing, keeps the group and stops sending messages to its members. A client that forwards group messages (an admin or owner in a group without relays, a relay in a channel) processes its own removal as without this property. +- clients of other members do not show the removal. + +Clients use `silent` and `notice` of a forwarded `x.grp.mem.del` message only when it is forwarded by a relay with a verified signature. Clients send `notice` only with `silent`, and only to members and contacts with chat protocol version 23 or later. ### Channels: relay-mediated groups diff --git a/docs/protocol/simplex-chat.schema.json b/docs/protocol/simplex-chat.schema.json index a9bb2d8735..60ead9033c 100644 --- a/docs/protocol/simplex-chat.schema.json +++ b/docs/protocol/simplex-chat.schema.json @@ -311,6 +311,24 @@ "memberRestrictions": { "properties": { "restriction": {"ref": "memberRestrictionStatus"} + }, + "optionalProperties": { + "expiresAt": { + "type": "string", + "metadata": { + "format": "ISO8601 UTC time when the block ends" + } + } + } + }, + "linkNotice": { + "optionalProperties": { + "ttl": { + "type": "integer", + "metadata": { + "format": "seconds from the server timestamp of the message" + } + } } }, "memberRestrictionStatus": { @@ -551,7 +569,11 @@ "properties": { "msgId": {"ref": "base64url"}, "params": { - "properties": {} + "properties": {}, + "optionalProperties": { + "silent": {"type": "boolean"}, + "notice": {"ref": "linkNotice"} + } } } }, @@ -692,6 +714,10 @@ "params": { "properties": { "memberId": {"ref": "base64url"} + }, + "optionalProperties": { + "silent": {"type": "boolean"}, + "notice": {"ref": "linkNotice"} } } } diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 900d4d62ec..fda89c959a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -436,7 +436,7 @@ data ChatCommand | APIChatRead {chatRef :: ChatRef} | APIChatItemsRead {chatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId} | APIChatUnread {chatRef :: ChatRef, unreadChat :: Bool} - | APIDeleteChat {chatRef :: ChatRef, chatDeleteMode :: ChatDeleteMode, notice :: Maybe LinkNotice} -- currently delete mode settings are only applied to direct chats + | APIDeleteChat {chatRef :: ChatRef, chatDeleteMode :: ChatDeleteMode, notice :: Maybe LinkNotice} | APIClearChat {chatRef :: ChatRef} | APIAcceptContact {incognito :: IncognitoEnabled, contactReqId :: Int64} | APIRejectContact {contactReqId :: Int64, notify :: Bool} @@ -474,7 +474,7 @@ data ChatCommand | APIAcceptMember {groupId :: GroupId, groupMemberId :: GroupMemberId, memberRole :: GroupMemberRole} | APIDeleteMemberSupportChat GroupId GroupMemberId | APIMembersRole {groupId :: GroupId, groupMemberIds :: NonEmpty GroupMemberId, memberRole :: GroupMemberRole} - | APIBlockMembersForAll {groupId :: GroupId, groupMemberIds :: NonEmpty GroupMemberId, blocked :: Bool} + | APIBlockMembersForAll {groupId :: GroupId, groupMemberIds :: NonEmpty GroupMemberId, blocked :: Bool, ttl :: Maybe Int} | APIRemoveMembers {groupId :: GroupId, groupMemberIds :: NonEmpty GroupMemberId, withMessages :: Bool, notice :: Maybe LinkNotice} | APILeaveGroup {groupId :: GroupId} | APIListMembers {groupId :: GroupId} @@ -623,7 +623,7 @@ data ChatCommand | JoinGroup {groupName :: GroupName, enableNtfs :: MsgFilter} | AcceptMember GroupName ContactName GroupMemberRole | MemberRole GroupName ContactName GroupMemberRole - | BlockForAll GroupName ContactName Bool + | BlockForAll GroupName ContactName Bool (Maybe Int) | RemoveMembers {groupName :: GroupName, members :: NonEmpty ContactName, withMessages :: Bool, notice :: Maybe LinkNotice} | LeaveGroup GroupName | AllowRelayGroup GroupName @@ -1162,6 +1162,7 @@ data ChatDeleteMode = CDMFull {notify :: Bool} -- delete both contact and conversation | CDMEntity {notify :: Bool} -- delete contact (connection), keep conversation | CDMMessages -- delete conversation, keep contact - can be re-opened from Contacts view + | CDMArchive deriving (Show) data ConnectionPlan @@ -1185,7 +1186,7 @@ data ContactAddressPlan | CAPConnectingProhibit {contact :: Contact} | CAPKnown {contact :: Contact} | CAPContactViaAddress {contact :: Contact} - | CAPLinkNotice {expiresAt :: Maybe UTCTime, reason :: Maybe ReportReason} + | CAPLinkNotice {expiresAt :: Maybe UTCTime, contactSLinkData_ :: Maybe ContactShortLinkData} deriving (Show) data GroupLinkPlan @@ -1196,7 +1197,7 @@ data GroupLinkPlan | GLPKnown {groupInfo :: GroupInfo, groupUpdated :: Bool, ownerVerification :: Maybe OwnerVerification, linkOwners :: ListDef GroupLinkOwner} | GLPNoRelays {groupSLinkData_ :: Maybe GroupShortLinkData} | GLPUpdateRequired {groupSLinkData_ :: Maybe GroupShortLinkData} - | GLPLinkNotice {expiresAt :: Maybe UTCTime, reason :: Maybe ReportReason} + | GLPLinkNotice {expiresAt :: Maybe UTCTime} deriving (Show) data GroupLinkOwner = GroupLinkOwner @@ -1534,7 +1535,7 @@ data ChatErrorType | CEUnsupportedConnReq | CEInvalidChatMessage {connection :: Connection, msgMeta :: Maybe MsgMetaJSON, messageData :: Text, message :: String} | CEConnReqMessageProhibited - | CELinkNotice {expiresAt :: Maybe UTCTime, reason :: Maybe ReportReason} + | CELinkNotice {expiresAt :: Maybe UTCTime} | CEContactNotFound {contactName :: ContactName, suspectedMember :: Maybe (GroupInfo, GroupMember)} | CEContactNotReady {contact :: Contact} | CEContactNotActive {contact :: Contact} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index fa31e03757..9ce20852a6 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1355,6 +1355,7 @@ processChatCommand cxt nm = \case APIDeleteChat cRef@(ChatRef cType chatId scope) cdm notice_ -> withUser $ \user@User {userId} -> case cType of CTDirect -> do ct <- withFastStore $ \db -> getContact db cxt user chatId + when (isJust notice_ && not (noticeSupported ct)) $ throwCmdError "contact does not support notice" filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct withContactLock "deleteChat direct" chatId $ case cdm of @@ -1381,54 +1382,79 @@ processChatCommand cxt nm = \case void $ processChatCommand cxt nm $ APIClearChat cRef withFastStore' $ \db -> setContactChatDeleted db user ct True pure $ CRContactDeleted user ct {chatDeleted = True} + CDMArchive -> do + when (isJust notice_) $ throwCmdError "notice requires deleting the contact" + withFastStore' $ \db -> setContactChatDeleted db user ct True + pure $ CRContactDeleted user ct {chatDeleted = True} where + noticeSupported ct = contactReady ct && contactActive ct && any (\Connection {peerChatVRange} -> maxVersion peerChatVRange >= linkNoticeVersion) (contactConn ct) sendDelDeleteConns ct notify = do - let delMsg_ - | not (contactReady ct && contactActive ct) = Nothing - | notify = Just $ XDirectDel False notice_ - | isJust notice_ && any (\Connection {peerChatVRange} -> maxVersion peerChatVRange >= linkNoticeVersion) (contactConn ct) = Just $ XDirectDel True notice_ - | otherwise = Nothing - forM_ delMsg_ $ \msg -> void (sendDirectContactMessage user ct msg) `catchAllErrors` const (pure ()) + let doSendDel = contactReady ct && contactActive ct && (notify || isJust notice_) + when doSendDel $ void (sendDirectContactMessage user ct (XDirectDel (isJust notice_) notice_)) `catchAllErrors` const (pure ()) contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db cxt userId ct) - deleteAgentConnectionsAsync' contactConnIds (isJust delMsg_) + deleteAgentConnectionsAsync' contactConnIds doSendDel CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId $ do when (isJust notice_) $ throwCmdError "notice is not supported for pending connections" + case cdm of + CDMArchive -> throwCmdError "archive is not supported for pending connections" + _ -> pure () conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withFastStore $ \db -> getPendingContactConnection db userId chatId deleteAgentConnectionAsync acId withFastStore' $ \db -> deletePendingContactConnection db userId chatId pure $ CRContactConnectionDeleted user conn CTGroup | isNothing scope -> do - g@(GIK gInfo@GroupInfo {membership} _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user chatId + g@(GIK gInfo@GroupInfo {membership, businessChat} _) <- withFastStore $ \db -> getGroupInfoKeys db cxt user chatId let isOwner = memberRole' membership == GROwner canDelete = isOwner || not (memberCurrent membership) + doSendDel = memberActive membership && isOwner + sendDelDeleteConns = do + (members, recipients) <- getRecipients gInfo + msgSigned <- + if doSendDel + then (\SndMessage {signedMsg_} -> isJust signedMsg_) <$> sendGroupMessage' user g recipients XGrpDel + else pure False + deleteGroupLinkIfExists user gInfo + deleteMembersConnections' user members doSendDel + updateCIGroupInvitationStatus user gInfo CIGISRejected `catchAllErrors` \_ -> pure () + withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo + pure msgSigned unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo - withGroupLock "deleteChat group" chatId $ do - deleteCIFiles user filesInfo - -- the roster blob file has no chat item, so it is missed by getGroupFileInfo above - cleanupGroupRosterFile user gInfo - (members, recipients) <- getRecipients gInfo - let doSendDel = memberActive membership && isOwner - msgSigned <- - if doSendDel - then (\SndMessage {signedMsg_} -> isJust signedMsg_) <$> sendGroupMessage' user g recipients (XGrpDel notice_) - else pure False - deleteGroupLinkIfExists user gInfo - deleteMembersConnections' user members doSendDel - updateCIGroupInvitationStatus user gInfo CIGISRejected `catchAllErrors` \_ -> pure () - withFastStore' $ \db -> deleteGroupChatItems db user gInfo - withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo - withFastStore' $ \db -> deleteGroupMembers db user gInfo - withFastStore' $ \db -> deleteGroup db user gInfo - pure $ CRGroupDeletedUser user gInfo msgSigned (not doSendDel) - where - getRecipients gInfo - | useRelays' gInfo = do - relays <- withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo - pure (relays, relays) - | otherwise = do - ms <- withFastStore' $ \db -> getGroupMembers db cxt user gInfo - pure (ms, filter memberCurrentOrPending ms) + case cdm of + CDMFull _ -> do + removeCustomer gInfo businessChat + withGroupLock "deleteChat group" chatId $ do + deleteCIFiles user filesInfo + -- the roster blob file has no chat item, so it is missed by getGroupFileInfo above + cleanupGroupRosterFile user gInfo + msgSigned <- sendDelDeleteConns + withFastStore' $ \db -> deleteGroupChatItems db user gInfo + withFastStore' $ \db -> deleteGroupMembers db user gInfo + withFastStore' $ \db -> deleteGroup db user gInfo + pure $ CRGroupDeletedUser user gInfo msgSigned (not doSendDel) + CDMEntity _ + | doSendDel -> do + removeCustomer gInfo businessChat + withGroupLock "deleteChat group" chatId $ do + cancelFilesInProgress user filesInfo + msgSigned <- sendDelDeleteConns + withFastStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted + pure $ CRGroupDeletedUser user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} msgSigned False + | otherwise -> throwCmdError "keeping the conversation requires an active owner" + _ -> throwCmdError "only full deletion or keeping the conversation is supported for groups" + where + getRecipients gInfo + | useRelays' gInfo = do + relays <- withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo + pure (relays, relays) + | otherwise = do + ms <- withFastStore' $ \db -> getGroupMembers db cxt user gInfo + pure (ms, filter memberCurrentOrPending ms) + removeCustomer gInfo businessChat = forM_ notice_ $ \notice -> case businessChat of + Just BusinessChatInfo {chatType = BCCustomer, customerId} -> do + GroupMember {groupMemberId} <- withFastStore $ \db -> getGroupMemberByMemberId db cxt user gInfo customerId + void $ processChatCommand cxt nm $ APIRemoveMembers chatId [groupMemberId] False (Just notice) + _ -> throwCmdError "notice is supported only for business chats" _ -> throwCmdError "not supported" APIClearChat (ChatRef cType chatId scope) -> withUser $ \user@User {userId} -> case cType of CTDirect -> do @@ -2293,7 +2319,6 @@ processChatCommand cxt nm = \case toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct') ci] pure $ CRStartedConnectionToContact user ct' customUserProfile Just PreparedContact {connLinkToConnect = ACCL SCMContact ccLink, welcomeSharedMsgId, requestSharedMsgId} -> do - checkLinkNotice $ connFullLink ccLink msg_ <- forM msgContent_ $ \mc -> case requestSharedMsgId of Just smId -> pure (smId, mc) Nothing -> do @@ -2385,7 +2410,6 @@ processChatCommand cxt nm = \case newConnIds <- getAgentConnShortLinkAsync user CFGetRelayDataJoin Nothing relayLink withStore' $ \db -> createRelayMemberConnectionAsync db user gInfo' relayMember relayLink newConnIds subMode GroupInfo {preparedGroup = Just PreparedGroup {connLinkToConnect, welcomeSharedMsgId, requestSharedMsgId}} -> do - checkLinkNotice $ connFullLink connLinkToConnect hostMember <- withFastStore $ \db -> getHostMember db cxt user groupId msg_ <- forM msgContent_ $ \mc -> case requestSharedMsgId of Just smId -> pure (smId, mc) @@ -2415,11 +2439,10 @@ processChatCommand cxt nm = \case (conn, incognitoProfile) <- connectViaInvitation user incognito ccLink Nothing let pcc = mkPendingContactConnection conn $ Just ccLink pure $ CRSentConfirmation user pcc incognitoProfile - ACCL SCMContact ccLink@(CCLink cReq sLnk) -> do + ACCL SCMContact ccLink@(CCLink _ sLnk) -> do case sLnk of Just (CSLContact _ CCTChannel _ _) -> throwChatError $ CECommandError "channel links must be connected via APIConnectPreparedGroup" _ -> pure () - checkLinkNotice cReq connectViaContact user Nothing incognito ccLink Nothing Nothing >>= \case CVRConnectedContact ct -> pure $ CRContactAlreadyExists user ct CVRSentInvitation conn incognitoProfile -> pure $ CRSentInvitation user (mkPendingContactConnection conn Nothing) incognitoProfile @@ -2933,6 +2956,7 @@ processChatCommand cxt nm = \case (g@(GIK gInfo _), m) <- withFastStore $ \db -> (,) <$> getGroupInfoKeys db cxt user groupId <*> getGroupMemberById db cxt user gmId -- same rule as role change (moderators grant up to member); pending member's role is a stand-in, so treat it as member assertUserGroupRole gInfo $ roleRequiredToChange GRMember role + when (blockedByAdmin m) $ throwCmdError "can't accept blocked member, unblock first" case memberStatus m of GSMemPendingApproval | memberCategory m == GCInviteeMember -> do -- only host can approve let GroupInfo {groupProfile = GroupProfile {memberAdmission}} = gInfo @@ -3090,7 +3114,7 @@ processChatCommand cxt nm = \case updMember db m = do updateGroupMemberRole db user m newRole pure (m :: GroupMember) {memberRole = newRole} - APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user -> + APIBlockMembersForAll groupId memberIds blockFlag ttl -> withUser $ \user -> withGroupLock "blockForAll" groupId $ do -- TODO [relays] possible optimization is to read only required members + relays (Group gInfo members, gks) <- withFastStore $ \db -> getGroupKeys_ db cxt user groupId @@ -3099,9 +3123,14 @@ processChatCommand cxt nm = \case let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && anyAdmin) $ throwCmdError "can't block/unblock multiple members when admins selected" - when anyPending $ throwCmdError "can't block/unblock members pending approval" + when (length memberIds > 1 && anyPending) $ throwCmdError "can't block/unblock multiple members when members pending approval selected" assertUserGroupRole gInfo $ max GRModerator maxRole - blockMembers user (GIK gInfo gks) blockMems remainingMems + now <- liftIO getCurrentTime + let mrs + | blockFlag = MemberRestrictions {restriction = MRSBlocked, expiresAt = capExpiry $ (`addUTCTime` now) . fromIntegral <$> ttl} + | otherwise = MemberRestrictions {restriction = MRSUnrestricted, expiresAt = Nothing} + (blocked, msgSigned) <- blockMembers user (GIK gInfo gks) mrs blockMems remainingMems + pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag, msgSigned} where selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool, Bool) @@ -3114,31 +3143,6 @@ processChatCommand cxt nm = \case anyPending' = anyPending || memberPending m in (m : block, remaining, maxRole', anyAdmin', anyPending') | otherwise = (block, m : remaining, maxRole, anyAdmin, anyPending) - blockMembers :: User -> GroupInfoKeys -> [GroupMember] -> [GroupMember] -> CM ChatResponse - blockMembers user g@(GIK gInfo _) blockMems remainingMems = case L.nonEmpty blockMems of - Nothing -> throwCmdError "no members to block/unblock" - Just blockMems' -> do - let mrs = if blockFlag then MRSBlocked else MRSUnrestricted - events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems' - recipients = filter memberCurrent remainingMems - (msgs_, _gsr) <- sendGroupMessages_ user g recipients False events - let msgSigned = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) msgs_ - itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False - when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch" - let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_ - unless (null acis) $ toView $ CEvtNewChatItems user acis - (errs, blocked) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updateGroupMemberBlocked db user gInfo mrs) blockMems) - unless (null errs) $ toView $ CEvtChatErrors errs - -- TODO not batched - requires agent batch api - forM_ blocked $ \m -> toggleNtf m (not blockFlag) - pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag, msgSigned} - where - sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c - sndItemData GroupMember {groupMemberId, memberProfile} msg = - let content = CISndGroupEvent $ SGEMemberBlocked groupMemberId (fromLocalProfile memberProfile) blockFlag - ts = ciContentTexts content - in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing APIRemoveMembers {groupId, groupMemberIds, withMessages, notice} -> withUser $ \user -> withGroupLock "removeMembers" groupId $ do -- TODO [relays] possible optimization is to read only required members + relays @@ -3151,6 +3155,8 @@ processChatCommand cxt nm = \case assertUserGroupRole gInfo $ max GRAdmin maxRole when (useRelays' gInfo && anyPrivilegedRemoved && memberRole' (membership gInfo) /= GROwner) $ throwCmdError "only the group owner can remove members, moderators and admins" + when (isJust notice && any noticeUnsupported (invitedMems <> pendingApprvMems <> pendingRvwMems <> currentMems)) $ + throwCmdError "notice is not supported for relays, members on old versions and members not in the group" (errs1, deleted1) <- deleteInvitedMems user invitedMems let recipients = filter memberCurrent members let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && anyRosterRemoved @@ -3195,6 +3201,7 @@ processChatCommand cxt nm = \case -- removed current member: alters the roster blob iff it currently holds a roster role _ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin', anyPrivRemoved', anyRosterRemoved || isRosterRole memberRole) | otherwise = acc + noticeUnsupported m = not (memberCurrentOrPending m) || isRelay m || not (m `supportsVersion` linkNoticeVersion) deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember]) deleteInvitedMems user memsToDelete = do deleteMembersConnections user memsToDelete @@ -3213,7 +3220,7 @@ processChatCommand cxt nm = \case Nothing -> pure ([], [], [], False) Just memsToDelete' -> do let chatScope = toChatScope <$> chatScopeInfo - events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages rosterVer notice) memsToDelete' + events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages rosterVer (isJust notice) notice) memsToDelete' (msgs_, _gsr) <- sendGroupMessages user g chatScope False recipients False events let signed = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) msgs_ itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_) @@ -3312,7 +3319,7 @@ processChatCommand cxt nm = \case processChatCommand cxt nm $ APIJoinGroup groupId enableNtfs AcceptMember gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIAcceptMember gId gMemberId memRole MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMembersRole gId [gMemberId] memRole - BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMembersForAll gId [gMemberId] blocked + BlockForAll gName gMemberName blocked ttl -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMembersForAll gId [gMemberId] blocked ttl RemoveMembers gName gMemberNames withMessages notice -> withUser $ \user -> do (gId, gMemberIds) <- withStore $ \db -> do gId <- getGroupIdByName db user gName @@ -3953,6 +3960,7 @@ processChatCommand cxt nm = \case Just (PCEGroup (GIK gInfo _) m) | useRelays' gInfo -> Just (memberId' m) _ -> Nothing joinPreparedConn' xContactId_ conn@Connection {connId, customUserProfileId} gInfo_ = do + checkLinkNotice cReq when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection" -- TODO [relays] member: refactor joinContact and up avoiding parallel ifs, xContactId is not used xContactId <- mkXContactId xContactId_ @@ -3961,6 +3969,7 @@ processChatCommand cxt nm = \case conn' <- joinContact user conn cReq' incognitoProfile reqHeader_ xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn pure $ CVRSentInvitation conn' incognitoProfile connect' groupLinkId xContactId_ gInfo_ = do + checkLinkNotice cReq let inGroup = isJust groupLinkId pqSup = if inGroup then PQSupportOff else PQSupportOn (connId, chatV, reqHeader) <- prepareContact user cReq pqSup @@ -4022,11 +4031,13 @@ processChatCommand cxt nm = \case syncSubscriberRelays :: User -> GroupInfo -> [ShortLinkContact] -> CM () syncSubscriberRelays user gInfo currentRelayLinks = void . tryAllErrors $ do localRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo + ts <- liftIO getCurrentTime + hasNotice <- withFastStore' $ \db -> maybe (pure False) (fmap isJust . getLinkNotice db ts . contactCReqHashes) (viaGroupLinkUri gInfo) let activeRelayMembers = filter memberCurrent localRelayMembers memberRelayLink GroupMember {relayLink = rl} = rl localRelayLinks = mapMaybe memberRelayLink activeRelayMembers newRelayLinks = filter (`notElem` localRelayLinks) currentRelayLinks - forM_ newRelayLinks $ \rlnk -> void . tryAllErrors $ + unless hasNotice $ forM_ newRelayLinks $ \rlnk -> void . tryAllErrors $ connectToRelayAsync user gInfo rlnk forM_ localRelayMembers $ \m -> case memberRelayLink m of @@ -4760,22 +4771,22 @@ processChatCommand cxt nm = \case ts <- liftIO getCurrentTime withFastStore' (\db -> (,) <$> getUserContactLinkByConnReq db user cReqSchemas <*> getLinkNotice db ts cReqHashes) >>= \case (Just _, _) -> plan $ CAPOwnLink - (Nothing, Just (expiresAt, reason)) -> plan $ CAPLinkNotice expiresAt reason - (Nothing, Nothing) -> + (Nothing, notice_) -> do + let okPlan = plan $ maybe (CAPOk cld ov) (`CAPLinkNotice` cld) notice_ withFastStore' (\db -> getContactConnEntityByConnReqHash db cxt user cReqHashes) >>= \case Nothing -> withFastStore' (\db -> getContactWithoutConnViaAddress db cxt user cReqSchemas) >>= \case Just ct | not (contactDeleted ct) -> plan $ CAPContactViaAddress ct - _ -> plan $ CAPOk cld ov + _ -> okPlan Just (RcvDirectMsgConnection Connection {connStatus} Nothing) - | connStatus == ConnPrepared -> plan $ CAPOk cld ov + | connStatus == ConnPrepared -> okPlan | otherwise -> plan CAPConnectingConfirmReconnect Just (RcvDirectMsgConnection _ (Just ct)) | not (contactReady ct) && contactActive ct -> plan $ CAPConnectingProhibit ct - | contactDeleted ct -> plan $ CAPOk cld ov + | contactDeleted ct -> okPlan | otherwise -> plan $ CAPKnown ct -- TODO [short links] RcvGroupMsgConnection branch is deprecated? (old group link protocol?) - Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing Nothing [] + Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo notice_ Nothing Nothing Nothing [] Just _ -> throwCmdError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection" groupJoinRequestPlan :: User -> ConnReqContact -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> [GroupLinkOwner] -> CM ConnectionPlan groupJoinRequestPlan user cReq linkInfo gld ov glOwners = do @@ -4785,28 +4796,29 @@ processChatCommand cxt nm = \case ts <- liftIO getCurrentTime withFastStore' (\db -> (,) <$> getGroupInfoByUserContactLinkConnReq db cxt user cReqSchemas <*> getLinkNotice db ts cReqHashes) >>= \case (Just g, _) -> plan $ GLPOwnLink g - (Nothing, Just (expiresAt, reason)) -> plan $ GLPLinkNotice expiresAt reason - (Nothing, Nothing) -> do + (Nothing, notice_) -> do connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db cxt user cReqHashes gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db cxt user cReqHashes case (gInfo_, connEnt_) of - (Nothing, Nothing) -> plan $ GLPOk linkInfo gld ov + (Nothing, Nothing) -> plan $ groupOkPlan notice_ linkInfo gld ov -- TODO [short links] RcvDirectMsgConnection branches are deprecated? (old group link protocol?) (Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> plan $ GLPConnectingConfirmReconnect (Nothing, Just (RcvDirectMsgConnection _ (Just ct))) | not (contactReady ct) && contactActive ct -> plan $ GLPConnectingProhibit gInfo_ - | otherwise -> plan $ GLPOk linkInfo gld ov + | otherwise -> plan $ groupOkPlan notice_ linkInfo gld ov (Nothing, Just _) -> throwCmdError "found connection entity is not RcvDirectMsgConnection" - (Just gInfo, _) -> groupPlan gInfo linkInfo gld ov glOwners - groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> [GroupLinkOwner] -> CM ConnectionPlan - groupPlan gInfo@GroupInfo {membership} linkInfo gld ov glOwners + (Just gInfo, _) -> groupPlan gInfo notice_ linkInfo gld ov glOwners + groupPlan :: GroupInfo -> Maybe (Maybe UTCTime) -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> [GroupLinkOwner] -> CM ConnectionPlan + groupPlan gInfo@GroupInfo {membership} notice_ linkInfo gld ov glOwners | memberStatus membership == GSMemRejected = plan $ GLPKnown gInfo False ov (ListDef glOwners) | not (memberActive membership) && not (memberRemoved membership) = plan $ GLPConnectingProhibit $ Just gInfo | memberActive membership = plan $ GLPKnown gInfo False ov (ListDef glOwners) - | otherwise = plan $ GLPOk linkInfo gld ov + | otherwise = plan $ groupOkPlan notice_ linkInfo gld ov where plan p = pure $ CPGroupLink p + groupOkPlan :: Maybe (Maybe UTCTime) -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> GroupLinkPlan + groupOkPlan notice_ linkInfo gld ov = maybe (GLPOk linkInfo gld ov) GLPLinkNotice notice_ contactCReqSchemas :: ConnReqContact -> (ConnReqContact, ConnReqContact) contactCReqSchemas (CRContactUri crData e2e) = ( CRContactUri crData {crScheme = SSSimplex} e2e, @@ -4818,7 +4830,7 @@ processChatCommand cxt nm = \case checkLinkNotice cReq = do ts <- liftIO getCurrentTime withFastStore' (\db -> getLinkNotice db ts $ contactCReqHashes cReq) - >>= mapM_ (\(expiresAt, reason) -> throwChatError $ CELinkNotice expiresAt reason) + >>= mapM_ (throwChatError . CELinkNotice) -- This function is needed, as UI uses simplex:/ schema in message view, so that the links can be handled without browser, -- and short links are stored with server hostname schema, so they wouldn't match without it. serverShortLink :: ConnShortLink m -> ConnShortLink m @@ -6087,6 +6099,35 @@ agentSubscriber = do type AgentSubResult = Map ConnId (Either AgentErrorType ()) +blockMembers :: User -> GroupInfoKeys -> MemberRestrictions -> [GroupMember] -> [GroupMember] -> CM ([GroupMember], Bool) +blockMembers user g@(GIK gInfo _) mrs@MemberRestrictions {restriction} blockMems remainingMems = case L.nonEmpty blockMems of + Nothing -> throwCmdError "no members to block/unblock" + Just blockMems' -> do + let events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId mrs) blockMems' + (msgs_, _gsr) <- sendGroupMessages_ user g recipients False events + let msgSigned = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) msgs_ + itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) + cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False + when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch" + let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_ + unless (null acis) $ toView $ CEvtNewChatItems user acis + (errs, blocked) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updateGroupMemberBlocked db user gInfo mrs True) blockMems) + unless (null errs) $ toView $ CEvtChatErrors errs + -- TODO not batched - requires agent batch api + forM_ blocked $ \m -> toggleNtf m (not blockFlag) + pure (blocked, msgSigned) + where + blockFlag = mrsBlocked restriction + recipients = case blockMems of + [GroupMember {memberStatus = GSMemPendingApproval}] -> [] + [GroupMember {memberStatus = GSMemPendingReview}] -> filter (\m -> memberRole' m >= GRModerator && memberCurrent m) remainingMems + _ -> filter memberCurrent remainingMems + sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c + sndItemData GroupMember {groupMemberId, memberProfile} msg = + let content = CISndGroupEvent $ SGEMemberBlocked groupMemberId (fromLocalProfile memberProfile) blockFlag + ts = ciContentTexts content + in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing + cleanupManager :: CM () cleanupManager = do interval <- asks (cleanupManagerInterval . config) @@ -6128,6 +6169,8 @@ cleanupManager = do liftIO $ threadDelay' stepDelay cleanupRemovedMembers user `catchAllErrors` eToView liftIO $ threadDelay' stepDelay + cleanupExpiredBlocks user `catchAllErrors` eToView + liftIO $ threadDelay' stepDelay cleanupTimedItems cleanupInterval user = do ts <- liftIO getCurrentTime let startTimedThreadCutoff = addUTCTime cleanupInterval ts @@ -6161,6 +6204,27 @@ cleanupManager = do removedMembers <- withStore' $ \db -> getRemovedMembersToCleanup db cxt user cutoffTs forM_ removedMembers $ \m -> withStore' (\db -> deleteGroupMember db user m) `catchAllErrors` eToView + cleanupExpiredBlocks user = do + cxt <- chatStoreCxt + ts <- liftIO getCurrentTime + expiredBlocks <- withStore' $ \db -> getExpiredBlocks db user ts + forM_ expiredBlocks $ \(groupId, gmId, byUser) -> + withGroupLock "blockForAll" groupId (unblockExpired cxt ts groupId gmId byUser) `catchAllErrors` eToView + where + unblockExpired cxt ts groupId gmId byUser = do + (gInfo@GroupInfo {membership}, m) <- withStore $ \db -> (,) <$> getGroupInfo db cxt user groupId <*> getGroupMember db cxt user groupId gmId + when (maybe False (<= ts) (blockedUntil m)) $ do + let mrs = MemberRestrictions {restriction = MRSUnrestricted, expiresAt = blockedUntil m} + ms' <- + if byUser && memberActive membership && memberRole' membership >= max GRModerator (memberRole' m) + then do + (Group gInfo' members, gks) <- withStore $ \db -> getGroupKeys_ db cxt user groupId + fst <$> blockMembers user (GIK gInfo' gks) mrs [m] (filter ((gmId /=) . groupMemberId') members) + else do + m' <- withStore' $ \db -> updateGroupMemberBlocked db user gInfo mrs False m + toggleNtf m' True + pure [m'] + forM_ ms' $ toView . CEvtGroupMemberUpdated user gInfo m cleanupMessages = do ts <- liftIO getCurrentTime let cutoffTs = addUTCTime (-(30 * nominalDay)) ts @@ -6445,7 +6509,7 @@ chatCommandP = "/_accept member #" *> (APIAcceptMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_delete member chat #" *> (APIDeleteMemberSupportChat <$> A.decimal <* A.space <*> A.decimal), "/_member role #" *> (APIMembersRole <$> A.decimal <*> _strP <*> memberRole), - "/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* " blocked=" <*> onOffP), + "/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* " blocked=" <*> onOffP <*> optional (" ttl=" *> A.decimal)), "/_remove #" *> (APIRemoveMembers <$> A.decimal <*> _strP <*> (" messages=" *> onOffP <|> pure False) <*> optional (" notice=" *> jsonP)), "/_leave #" *> (APILeaveGroup <$> A.decimal), "/_members #" *> (APIListMembers <$> A.decimal), @@ -6544,8 +6608,8 @@ chatCommandP = ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayNameP <*> (" mute" $> MFNone <|> pure MFAll)), "/accept member " *> char_ '#' *> (AcceptMember <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> (memberRole <|> pure GRMember)), ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> memberRole), - "/block for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure True), - "/unblock for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure False), + "/block for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure True <*> optional (" ttl=" *> A.decimal)), + "/unblock for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure False <*> pure Nothing), ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMembers <$> displayNameP <* A.space <*> (L.fromList <$> (char_ '@' *> displayNameP) `A.sepBy1'` A.char ',') <*> (" messages=" *> onOffP <|> pure False) <*> optional (" notice=" *> jsonP)), ("/leave " <|> "/l ") *> char_ '#' *> (LeaveGroup <$> displayNameP), ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayNameP), @@ -6747,6 +6811,7 @@ chatCommandP = [ " full" *> (CDMFull <$> notifyP), " entity" *> (CDMEntity <$> notifyP), " messages" $> CDMMessages, + " archive" $> CDMArchive, CDMFull <$> notifyP -- backwards compatible ] where diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 8c9e23ee30..bc2b8b571e 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -1084,7 +1084,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag where MsgContainer {scope, asGroup} = mc -- file description is always allowed, to allow sending files to support scope - XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires fileBadge + XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires fileBadge msg XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> checkSendAsGroup asGroup_ $ memberCanSend (Just m'') msgScope $ @@ -1111,11 +1111,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag XGrpMemRole memId memRole memberKey rosterVer -> fmap ctx <$> xGrpMemRole (GIK gInfo' gks) Nothing m'' memId memRole memberKey rosterVer msg brokerTs XGrpMemRestrict memId memRestrictions -> fmap ctx <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId - XGrpMemDel memId withMessages rosterVer notice_ -> case encoding @e of - SJson -> fmap ctx <$> xGrpMemDel (GIK gInfo' gks) Nothing m'' memId withMessages rosterVer notice_ verifiedMsg msg brokerTs False + XGrpMemDel memId withMessages rosterVer silent notice_ -> case encoding @e of + SJson -> fmap ctx <$> xGrpMemDel (GIK gInfo' gks) Nothing m'' memId withMessages rosterVer silent notice_ verifiedMsg msg brokerTs False SBinary -> pure Nothing XGrpLeave -> fmap ctx <$> xGrpLeave (GIK gInfo' gks) m'' msg brokerTs - XGrpDel notice_ -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' notice_ msg brokerTs + XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs XGrpInfo p' -> fmap ctx <$> xGrpInfo (GIK gInfo' gks) m'' p' msg brokerTs XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' msg XGrpRoster gr -> fmap ctx <$> xGrpRoster gInfo' m'' m'' gr verifiedMsg sharedMsgId_ brokerTs @@ -1719,6 +1719,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem' + blockedForUser :: GroupInfo -> GroupMember -> Bool + blockedForUser GroupInfo {membership} m = blockedByAdmin m && memberRole' membership < GRModerator + + deleteRcvMsg :: RcvMessage -> CM () + deleteRcvMsg RcvMessage {msgId} = withStore' (`deleteRcvMessage` msgId) + muteEventInChannel :: GroupInfo -> GroupMember -> Bool muteEventInChannel gInfo@GroupInfo {membership} m = useRelays' gInfo @@ -1975,22 +1981,24 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag binding_ <- if isJust fileBadge then directChatBinding ct else pure Nothing processFDMessage binding_ fileId aci fileDescr fileExpires fileBadge - groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM (Maybe DeliveryTaskContext) - groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr fileExpires fileBadge = do - (fileId, aci) <- withStore $ \db -> do - fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - aci <- getChatItemByFileId db cxt user fileId - pure (fileId, aci) - case aci of - AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir, meta = CIMeta {showGroupAsSender}} - | validSender m_ chatDir -> do - -- in processFDMessage some paths are programmed as errors, - -- for example failure on not approved relays (CEFileNotApproved). - -- we catch error, so that even if processFDMessage fails, message can still be forwarded. - processFDMessage (rcvGroupChatBinding g m_ showGroupAsSender fileBadge) fileId aci fileDescr fileExpires fileBadge `catchAllErrors` \_ -> pure () - pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir) - | otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing - _ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing + groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> RcvMessage -> CM (Maybe DeliveryTaskContext) + groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr fileExpires fileBadge msg + | maybe False (blockedForUser g) m_ = Nothing <$ deleteRcvMsg msg + | otherwise = do + (fileId, aci) <- withStore $ \db -> do + fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + aci <- getChatItemByFileId db cxt user fileId + pure (fileId, aci) + case aci of + AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir, meta = CIMeta {showGroupAsSender}} + | validSender m_ chatDir -> do + -- in processFDMessage some paths are programmed as errors, + -- for example failure on not approved relays (CEFileNotApproved). + -- we catch error, so that even if processFDMessage fails, message can still be forwarded. + processFDMessage (rcvGroupChatBinding g m_ showGroupAsSender fileBadge) fileId aci fileDescr fileExpires fileBadge `catchAllErrors` \_ -> pure () + pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir) + | otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing + _ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing processFDMessage :: Maybe ByteString -> FileTransferId -> AChatItem -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM () processFDMessage binding_ fileId aci fileDescr fileExpires fileBadge = do @@ -2213,6 +2221,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- no delivery task - message already forwarded by relay pure Nothing Just m@GroupMember {memberId} + | blockedForUser gInfo m -> Nothing <$ deleteRcvMsg msg -- only an owner may post as the channel; a non-owner's signed asGroup post (e.g. relay-injected) must not render as the channel | sentAsGroup && memberRole' m < GROwner -> messageError "x.msg.new: member is not allowed to send as group" $> Nothing @@ -2305,9 +2314,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvGroupCITimed gInfo ttl_ showGroupAsSender = fromMaybe (isNothing m_) asGroup_ - if showGroupAsSender && maybe False (\m -> memberRole' m < GROwner) m_ - then messageError "x.msg.update: member attempted to update as group" $> Nothing - else do + if + | maybe False (blockedForUser gInfo) m_ -> Nothing <$ deleteRcvMsg msg + | showGroupAsSender && maybe False (\m -> memberRole' m < GROwner) m_ -> + messageError "x.msg.update: member attempted to update as group" $> Nothing + | otherwise -> do (gInfo', chatDir, mentions', scopeInfo) <- if showGroupAsSender then pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing) @@ -2520,18 +2531,20 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- TODO remove once XFile is discontinued processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM () - processGroupFileInvitation' gInfo m fInv msg@RcvMessage {sharedMsgId_} brokerTs = do - ChatConfig {fileChunkSize} <- asks config - fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv - fileProhibited <- rcvGroupFileProhibited gInfo (Just m) False fInv' - inline <- receiveInlineMode fInv' Nothing fileChunkSize - RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' fileProhibited inline fileChunkSize - let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP - ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing, fileProhibited} - content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" - (ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty - ci' <- blockedMemberCI gInfo m ci - groupMsgToView cInfo ci' + processGroupFileInvitation' gInfo m fInv msg@RcvMessage {sharedMsgId_} brokerTs + | blockedForUser gInfo m = deleteRcvMsg msg + | otherwise = do + ChatConfig {fileChunkSize} <- asks config + fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv + fileProhibited <- rcvGroupFileProhibited gInfo (Just m) False fInv' + inline <- receiveInlineMode fInv' Nothing fileChunkSize + RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' fileProhibited inline fileChunkSize + let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP + ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing, fileProhibited} + content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" + (ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty + ci' <- blockedMemberCI gInfo m ci + groupMsgToView cInfo ci' blockedMemberCI :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> CM (ChatItem 'CTGroup 'MDRcv) blockedMemberCI gInfo m ci @@ -3692,10 +3705,10 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpMemRestrict - gInfo@GroupInfo {membership = GroupMember {memberId = membershipMemId}} + gInfo@GroupInfo {membership = GroupMember {memberId = membershipMemId, memberRole = userRole}} m@GroupMember {memberRole = senderRole} memId - MemberRestrictions {restriction} + mrs@MemberRestrictions {restriction, expiresAt} msg@RcvMessage {msgSigned} brokerTs | membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency @@ -3706,22 +3719,24 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag Just (bm, unknown) -> do let GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} = bm if - | blockedByAdmin == mrsBlocked restriction -> pure Nothing | senderRole < GRModerator || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" $> Nothing + | blockedByAdmin == blocked || automaticUnblock -> pure $ memberEventDeliveryScope bm | otherwise -> do bm' <- setMemberBlocked bm toggleNtf bm' (not blocked) let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m - (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent + when (userRole >= GRModerator) $ do + (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent + groupMsgToView cInfo ci when unknown $ toView $ CEvtUnknownMemberBlocked user gInfo m bm' - groupMsgToView cInfo ci toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked, msgSigned} pure $ memberEventDeliveryScope bm where - setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm + setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo mrs False bm blocked = mrsBlocked restriction + automaticUnblock = not blocked && isJust expiresAt xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM () xGrpMemCon gInfo sendingMem memId = do @@ -3730,23 +3745,28 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected - xGrpMemDel :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> Maybe LinkNotice -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope) - xGrpMemDel g@(GIK gInfo@GroupInfo {membership} gks) fwdRelay_ m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ notice_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do + xGrpMemDel :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> Bool -> Maybe LinkNotice -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope) + xGrpMemDel g@(GIK gInfo@GroupInfo {membership} gks) fwdRelay_ m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ silent notice_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do let GroupMember {memberId = membershipMemId} = membership + trusted = not forwarded || (useRelays' gInfo && msgSigned == Just MSSVerified) + silent' = trusted && silent if membershipMemId == memId then applyAtRosterVersion g fwdRelay_ m rosterVer_ $ checkRole membership $ do deleteGroupLinkIfExists user gInfo - -- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay - unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False - withStore' $ \db -> do - updateGroupMemberStatus db userId membership GSMemRemoved - when (maybe False (/= RSRejected) (relayOwnStatus gInfo)) $ updateRelayOwnStatus_ db gInfo RSInactive - forM_ notice_ $ setGroupLinkNotice db gInfo brokerTs - let membership' = membership {memberStatus = GSMemRemoved} - when withMessages $ deleteMessages gInfo membership' - deleteMemberItem msg gInfo RGEUserDeleted - toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned - pure $ Just DJSGroup {jobSpec = DJRelayRemoved} + when trusted $ forM_ notice_ $ \notice -> withStore' $ \db -> setGroupLinkNotice db gInfo brokerTs notice + if silent' && not (isUserGrpFwdRelay gInfo) + then Nothing <$ (mapM_ deleteMemberConnection =<< getGroupConnMembers user gInfo) + else do + -- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay + unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False + withStore' $ \db -> do + updateGroupMemberStatus db userId membership GSMemRemoved + when (maybe False (/= RSRejected) (relayOwnStatus gInfo)) $ updateRelayOwnStatus_ db gInfo RSInactive + let membership' = membership {memberStatus = GSMemRemoved} + when withMessages $ deleteMessages gInfo membership' + deleteMemberItem msg gInfo RGEUserDeleted + toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned + pure $ Just DJSGroup {jobSpec = DJRelayRemoved} else applyAtRosterVersion g fwdRelay_ m rosterVer_ $ withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case Left _ -> do @@ -3779,7 +3799,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- as the member record was already deleted above. let RcvMessage {forwardedByMember = fwdBy} = msg msg' = if fwdBy == Just groupMemberId then (msg :: RcvMessage) {forwardedByMember = Nothing} else msg - unless wasDeleted $ deleteMemberItem msg' gInfo'' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) + unless (wasDeleted || silent') $ deleteMemberItem msg' gInfo'' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) toView $ CEvtDeletedMember user gInfo'' m deletedMember' withMessages msgSigned pure deliveryScope where @@ -3828,13 +3848,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag toView $ CEvtLeftMember user gInfo''' m' {memberStatus = GSMemLeft} msgSigned pure $ memberEventDeliveryScope m - xGrpDel :: GroupInfo -> GroupMember -> Maybe LinkNotice -> RcvMessage -> UTCTime -> CM () - xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} notice_ msg@RcvMessage {msgSigned} brokerTs = do + xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () + xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg@RcvMessage {msgSigned} brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner deleteGroupLinkIfExists user gInfo - withStore' $ \db -> do - updateGroupMemberStatus db userId membership GSMemGroupDeleted - forM_ notice_ $ setGroupLinkNotice db gInfo brokerTs + withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted -- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m @@ -4049,7 +4067,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag where MsgContainer {scope} = mc -- file description is always allowed, to allow sending files to support scope - XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires fileBadge + XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires fileBadge rcvMsg XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_ XMsgDel sharedMsgId memId scope_ _ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ False rcvMsg msgTs @@ -4060,9 +4078,9 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew g author memInfo msgScope rcvMsg msgTs XGrpMemRole memId memRole memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole g (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs XGrpMemRestrict memId memRestrictions -> withAuthor XGrpMemRestrict_ $ \author -> void $ xGrpMemRestrict gInfo author memId memRestrictions rcvMsg msgTs - XGrpMemDel memId withMessages rosterVer notice_ -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel g (Just m) author memId withMessages rosterVer notice_ verifiedMsg rcvMsg msgTs True + XGrpMemDel memId withMessages rosterVer silent notice_ -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel g (Just m) author memId withMessages rosterVer silent notice_ verifiedMsg rcvMsg msgTs True XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave g author rcvMsg msgTs - XGrpDel notice_ -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author notice_ rcvMsg msgTs + XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo g author p' rcvMsg msgTs XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' rcvMsg XGrpRoster gr -> withAuthor XGrpRoster_ $ \author -> void $ xGrpRoster gInfo m author gr verifiedMsg sharedMsgId_ msgTs @@ -4179,11 +4197,15 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag _ -> pure Nothing deleteGroupConnections :: User -> GroupInfo -> Bool -> CM () -deleteGroupConnections user gInfo@GroupInfo {membership} waitDelivery = do - cxt <- chatStoreCxt +deleteGroupConnections user gInfo waitDelivery = do -- member records are not deleted to keep history - members <- getMembers cxt + members <- getGroupConnMembers user gInfo deleteMembersConnections' user members waitDelivery + +getGroupConnMembers :: User -> GroupInfo -> CM [GroupMember] +getGroupConnMembers user gInfo@GroupInfo {membership} = do + cxt <- chatStoreCxt + getMembers cxt where getMembers cxt | useRelays' gInfo, not (isRelay membership) = withStore' $ \db -> getGroupRelayMembers db cxt user gInfo diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 4c7421eb9e..9ad815435b 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -300,7 +300,6 @@ instance StrEncoding ReportReason where A.takeTill (== ' ') >>= \case "spam" -> pure RRSpam "content" -> pure RRContent - "illegal" -> pure RRContent "community" -> pure RRCommunity "profile" -> pure RRProfile "other" -> pure RROther @@ -313,13 +312,8 @@ instance ToJSON ReportReason where toJSON = strToJSON toEncoding = strToJEncoding -instance ToField ReportReason where toField = toField . safeDecodeUtf8 . strEncode - -instance FromField ReportReason where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - data LinkNotice = LinkNotice - { ttl :: Maybe Int64, - reason :: Maybe ReportReason + { ttl :: Maybe Int64 } deriving (Eq, Show) @@ -510,9 +504,9 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpMemRestrict :: MemberId -> MemberRestrictions -> ChatMsgEvent 'Json XGrpMemCon :: MemberId -> ChatMsgEvent 'Json XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented - XGrpMemDel :: MemberId -> Bool -> Maybe VersionRoster -> Maybe LinkNotice -> ChatMsgEvent 'Json + XGrpMemDel :: MemberId -> Bool -> Maybe VersionRoster -> Bool -> Maybe LinkNotice -> ChatMsgEvent 'Json XGrpLeave :: ChatMsgEvent 'Json - XGrpDel :: Maybe LinkNotice -> ChatMsgEvent 'Json + XGrpDel :: ChatMsgEvent 'Json XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json @@ -559,7 +553,7 @@ isForwardedGroupMsg ev = case ev of XGrpMemRestrict {} -> True XGrpMemDel {} -> True XGrpLeave -> True - XGrpDel _ -> True + XGrpDel -> True XGrpInfo _ -> True XGrpPrefs _ -> True XGrpRoster _ -> True @@ -1316,7 +1310,7 @@ toCMEventTag msg = case msg of XGrpMemConAll _ -> XGrpMemConAll_ XGrpMemDel {} -> XGrpMemDel_ XGrpLeave -> XGrpLeave_ - XGrpDel _ -> XGrpDel_ + XGrpDel -> XGrpDel_ XGrpInfo _ -> XGrpInfo_ XGrpPrefs _ -> XGrpPrefs_ XGrpDirectInv {} -> XGrpDirectInv_ @@ -1492,9 +1486,9 @@ appJsonToCM fwdDepth AppMessageJson {v, msgId, event, params} = do XGrpMemRestrict_ -> XGrpMemRestrict <$> p "memberId" <*> p "memberRestrictions" XGrpMemCon_ -> XGrpMemCon <$> p "memberId" XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId" - XGrpMemDel_ -> XGrpMemDel <$> p "memberId" <*> Right (fromRight False $ p "messages") <*> opt "rosterVersion" <*> Right (fromRight Nothing $ opt "notice") + XGrpMemDel_ -> XGrpMemDel <$> p "memberId" <*> Right (fromRight False $ p "messages") <*> opt "rosterVersion" <*> Right (fromRight False $ p "silent") <*> Right (fromRight Nothing $ opt "notice") XGrpLeave_ -> pure XGrpLeave - XGrpDel_ -> XGrpDel <$> Right (fromRight Nothing $ opt "notice") + XGrpDel_ -> pure XGrpDel XGrpInfo_ -> XGrpInfo <$> p "groupProfile" XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences" XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope" @@ -1568,9 +1562,9 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en XGrpMemRestrict memId memRestrictions -> o ["memberId" .= memId, "memberRestrictions" .= memRestrictions] XGrpMemCon memId -> o ["memberId" .= memId] XGrpMemConAll memId -> o ["memberId" .= memId] - XGrpMemDel memId messages rosterVersion notice -> o $ ("notice" .=? notice) $ ("rosterVersion" .=? rosterVersion) $ ("messages" .=? if messages then Just True else Nothing) ["memberId" .= memId] + XGrpMemDel memId messages rosterVersion silent notice -> o $ ("notice" .=? notice) $ ("silent" .=? justTrue silent) $ ("rosterVersion" .=? rosterVersion) $ ("messages" .=? if messages then Just True else Nothing) ["memberId" .= memId] XGrpLeave -> JM.empty - XGrpDel notice -> o $ ("notice" .=? notice) [] + XGrpDel -> JM.empty XGrpInfo p -> o ["groupProfile" .= p] XGrpPrefs p -> o ["groupPreferences" .= p] XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq] diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 0a58b1cfd9..1118a5e617 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -164,14 +164,14 @@ getConnectionEntityKeys db cxt user@User {userId, userContactId} agentConnId = d g.root_priv_key, g.root_pub_key, g.member_priv_key, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.index_in_group, 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, + mu.member_status, mu.show_messages, mu.member_restriction, mu.member_restriction_expires_at, 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.short_descr, pu.description, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, pu.preferences_json, pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.contact_domain, pu.contact_domain_proof, pu.contact_domain_verified, mu.created_at, mu.updated_at, mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link, mu.member_security_code, mu.member_security_code_verified_at, -- from GroupMember - m.group_member_id, m.group_id, m.index_in_group, 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.group_member_id, m.group_id, m.index_in_group, 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.member_restriction_expires_at, 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.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.preferences_json, p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, m.created_at, m.updated_at, diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 839a3d5746..4862fbc42a 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -77,6 +77,7 @@ module Simplex.Chat.Store.Groups getGroupRelayMembers, getGroupMembersForExpiration, getRemovedMembersToCleanup, + getExpiredBlocks, deleteGroupChatItems, deleteGroupMembers, cleanupHostGroupLinkConn, @@ -266,11 +267,11 @@ import Database.SQLite.Simple (Only (..), Query, (:.) (..)) import Database.SQLite.Simple.QQ (sql) #endif -type MaybeGroupMemberRow = (Maybe GroupMemberId, Maybe GroupId, Maybe Int64, Maybe MemberId, Maybe VersionChat, Maybe VersionChat, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId) :. ((Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe LocalAlias, Maybe Text, Maybe Text) :. BadgeRow :. ContactDomainRow) :. (Maybe UTCTime, Maybe UTCTime) :. (Maybe UTCTime, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact, Maybe Text, Maybe UTCTime) +type MaybeGroupMemberRow = (Maybe GroupMemberId, Maybe GroupId, Maybe Int64, Maybe MemberId, Maybe VersionChat, Maybe VersionChat, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe BoolInt, Maybe MemberRestrictionStatus, Maybe UTCTime) :.(Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId) :. ((Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe LocalAlias, Maybe Text, Maybe Text) :. BadgeRow :. ContactDomainRow) :. (Maybe UTCTime, Maybe UTCTime) :. (Maybe UTCTime, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact, Maybe Text, Maybe UTCTime) toMaybeGroupMember :: UTCTime -> Int64 -> MaybeGroupMemberRow -> Maybe GroupMember -toMaybeGroupMember now userContactId ((Just groupMemberId, Just groupId, Just indexInGroup, 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, shortDescr, description, image, contactLink, peerType, Just localAlias, encodedPrefs, receivedPrefs) :. badgeRow :. domainRow) :. (Just createdAt, Just updatedAt) :. (supportChatTs, Just supportChatUnread, Just supportChatUnanswered, Just supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) = - Just $ toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberBlocked') :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. ((profileId, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, encodedPrefs, receivedPrefs) :. badgeRow :. domainRow) :. (createdAt, updatedAt) :. (supportChatTs, supportChatUnread, supportChatUnanswered, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) +toMaybeGroupMember now userContactId ((Just groupMemberId, Just groupId, Just indexInGroup, Just memberId, Just minVer, Just maxVer, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages, memberBlocked', blockedUntil) :.(invitedById, invitedByGroupMemberId, Just localDisplayName, memberContactId, Just memberContactProfileId) :. ((Just profileId, Just displayName, Just fullName, shortDescr, description, image, contactLink, peerType, Just localAlias, encodedPrefs, receivedPrefs) :. badgeRow :. domainRow) :. (Just createdAt, Just updatedAt) :. (supportChatTs, Just supportChatUnread, Just supportChatUnanswered, Just supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) = + Just $ toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberBlocked', blockedUntil) :.(invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. ((profileId, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, encodedPrefs, receivedPrefs) :. badgeRow :. domainRow) :. (createdAt, updatedAt) :. (supportChatTs, supportChatUnread, supportChatUnanswered, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) toMaybeGroupMember _ _ _ = Nothing createGroupLink :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> ConnId -> CreatedLinkContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO GroupLink @@ -606,6 +607,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe memberStatus, memberSettings = defaultMemberSettings, blockedByAdmin = False, + blockedUntil = Nothing, invitedBy, invitedByGroupMemberId, localDisplayName, @@ -1381,6 +1383,19 @@ getRemovedMembersToCleanup db cxt user@User {userId} cutoffTs = do (groupMemberQuery <> " WHERE m.user_id = ? AND m.removed_at < ?") (userId, cutoffTs) +getExpiredBlocks :: DB.Connection -> User -> UTCTime -> IO [(GroupId, GroupMemberId, Bool)] +getExpiredBlocks db User {userId} now = + map (\(groupId, groupMemberId, BI byUser) -> (groupId, groupMemberId, byUser)) + <$> DB.query + db + [sql| + SELECT group_id, group_member_id, member_restriction_by_user + FROM group_members + WHERE user_id = ? AND member_restriction = ? AND member_restriction_expires_at <= ? + AND member_status NOT IN (?,?,?,?) + |] + (userId, MRSBlocked, now, GSMemRejected, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + getGroupInvitation :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation getGroupInvitation db cxt user groupId = getConnRec_ user >>= \case @@ -1422,6 +1437,7 @@ createNewContactMember db gVar User {userId, userContactId} GroupInfo {groupId, memberStatus = GSMemInvited, memberSettings = defaultMemberSettings, blockedByAdmin = False, + blockedUntil = Nothing, invitedBy = IBUser, invitedByGroupMemberId = Just invitedByGroupMemberId, localDisplayName, @@ -2533,6 +2549,8 @@ createNewMember_ memberChatVRange@(VersionRange minV maxV) = maybe chatInitialVRange fromChatVRange memChatVRange memberPubKey = (\(MemberKey k) -> k) <$> memKey memberProof = verifiedProof badgeVerified badge + restriction_ = restriction <$> memRestriction + blockedUntil = memRestriction >>= blockExpiry indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ DB.execute @@ -2540,13 +2558,13 @@ createNewMember_ [sql| INSERT INTO group_members (group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, - member_restriction, invited_by, invited_by_group_member_id, + member_restriction, member_restriction_expires_at, invited_by, invited_by_group_member_id, user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at, peer_chat_min_version, peer_chat_max_version) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] ( (groupId, indexInGroup, memberId, memberRole, memberCategory, memberStatus, Binary B.empty) - :. (memRestriction, invitedById, memInvitedByGroupMemberId) + :. (restriction_, blockedUntil, invitedById, memInvitedByGroupMemberId) :. (userId, localDisplayName, memberContactId, memberContactProfileId, memberPubKey, createdAt, createdAt) :. (minV, maxV) ) @@ -2562,7 +2580,8 @@ createNewMember_ memberCategory, memberStatus, memberSettings = defaultMemberSettings, - blockedByAdmin = maybe False mrsBlocked memRestriction, + blockedByAdmin = blockedAt createdAt restriction_ blockedUntil, + blockedUntil, invitedBy, invitedByGroupMemberId = memInvitedByGroupMemberId, localDisplayName, @@ -2693,8 +2712,7 @@ createIntroReMember memRestrictions_ = do currentTs <- liftIO getCurrentTime (localDisplayName, memProfileId, memberProfile', badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile presHeader_ currentTs - let memRestriction = restriction <$> memRestrictions_ - newMember = NewGroupMember {memInfo = (memInfo :: MemberInfo) {profile = memberProfile'}, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} + let newMember = NewGroupMember {memInfo = (memInfo :: MemberInfo) {profile = memberProfile'}, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction = memRestrictions_, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} createNewMember_ db user (groupId' gInfo) newMember badgeVerified currentTs createIntroReMemberConn :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionChat -> MemberInfo -> (CommandId, ConnId) -> SubscriptionMode -> ExceptT StoreError IO GroupMember @@ -3223,18 +3241,20 @@ updateGroupMemberSettings db User {userId} gId gMemberId GroupMemberSettings {sh |] (BI showMessages, currentTs, userId, gId, gMemberId) -updateGroupMemberBlocked :: DB.Connection -> User -> GroupInfo -> MemberRestrictionStatus -> GroupMember -> IO GroupMember -updateGroupMemberBlocked db User {userId} GroupInfo {groupId} mrs m@GroupMember {groupMemberId} = do +updateGroupMemberBlocked :: DB.Connection -> User -> GroupInfo -> MemberRestrictions -> Bool -> GroupMember -> IO GroupMember +updateGroupMemberBlocked db User {userId} GroupInfo {groupId} mrs@MemberRestrictions {restriction} byUser m@GroupMember {groupMemberId} = do currentTs <- getCurrentTime DB.execute db [sql| UPDATE group_members - SET member_restriction = ?, updated_at = ? + SET member_restriction = ?, member_restriction_expires_at = ?, member_restriction_by_user = ?, updated_at = ? WHERE user_id = ? AND group_id = ? AND group_member_id = ? |] - (mrs, currentTs, userId, groupId, groupMemberId) - pure m {blockedByAdmin = mrsBlocked mrs} + (restriction, blockedUntil, BI byUser, currentTs, userId, groupId, groupMemberId) + pure m {blockedByAdmin = blockedAt currentTs (Just restriction) blockedUntil, blockedUntil} + where + blockedUntil = blockExpiry mrs getHostConnId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId getHostConnId db user@User {userId} groupId = do diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index ee5a7f1659..0e737a0a72 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -35,6 +35,7 @@ module Simplex.Chat.Store.Messages getPendingGroupMessages, deletePendingGroupMessage, deleteOldMessages, + deleteRcvMessage, MemberAttention (..), updateChatTsStats, setSupportChatTs, @@ -393,6 +394,9 @@ deleteOldMessages :: DB.Connection -> UTCTime -> IO () deleteOldMessages db createdAtCutoff = do DB.execute db "DELETE FROM messages WHERE created_at <= ?" (Only createdAtCutoff) +deleteRcvMessage :: DB.Connection -> MessageId -> IO () +deleteRcvMessage db msgId = DB.execute db "DELETE FROM messages WHERE message_id = ?" (Only msgId) + type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId) -- For support chats with members we track unanswered count - number of messages from the member @@ -724,7 +728,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe SELECT i.chat_item_id, -- GroupMember m.group_member_id, m.group_id, m.index_in_group, 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, + m.member_status, m.show_messages, m.member_restriction, m.member_restriction_expires_at, 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.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.preferences_json, p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, m.created_at, m.updated_at, @@ -3119,7 +3123,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do i.forwarded_by_group_member_id, i.show_group_as_sender, -- GroupMember m.group_member_id, m.group_id, m.index_in_group, 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, + m.member_status, m.show_messages, m.member_restriction, m.member_restriction_expires_at, 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.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.preferences_json, p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, m.created_at, m.updated_at, @@ -3128,14 +3132,14 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do 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.index_in_group, 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.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, + rm.member_status, rm.show_messages, rm.member_restriction, rm.member_restriction_expires_at, 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.short_descr, rp.description, rp.image, rp.contact_link, rp.chat_peer_type, rp.local_alias, rp.preferences, rp.preferences_json, rp.badge_proof, rp.badge_pres_header, rp.badge_expiry, rp.badge_type, rp.badge_verified, rp.badge_extra, rp.badge_master_key, rp.badge_signature, rp.badge_key_idx, rp.contact_domain, rp.contact_domain_proof, rp.contact_domain_verified, rm.created_at, rm.updated_at, rm.support_chat_ts, rm.support_chat_items_unread, rm.support_chat_items_member_attention, rm.support_chat_items_mentions, rm.support_chat_last_msg_from_member_ts, rm.member_pub_key, rm.relay_link, rm.member_security_code, rm.member_security_code_verified_at, -- deleted by GroupMember dbm.group_member_id, dbm.group_id, dbm.index_in_group, 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.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, + dbm.member_status, dbm.show_messages, dbm.member_restriction, dbm.member_restriction_expires_at, 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.short_descr, dbp.description, dbp.image, dbp.contact_link, dbp.chat_peer_type, dbp.local_alias, dbp.preferences, dbp.preferences_json, dbp.badge_proof, dbp.badge_pres_header, dbp.badge_expiry, dbp.badge_type, dbp.badge_verified, dbp.badge_extra, dbp.badge_master_key, dbp.badge_signature, dbp.badge_key_idx, dbp.contact_domain, dbp.contact_domain_proof, dbp.contact_domain_verified, dbm.created_at, dbm.updated_at, diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20261020_link_notices.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20261020_link_notices.hs index cc9b690222..ac22846bb5 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20261020_link_notices.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20261020_link_notices.hs @@ -13,17 +13,26 @@ CREATE TABLE link_notices( link_notice_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, link_hash BYTEA NOT NULL, expires_at TIMESTAMPTZ, - reason TEXT, created_at TIMESTAMPTZ NOT NULL, updated_at TIMESTAMPTZ NOT NULL ); CREATE UNIQUE INDEX idx_link_notices_link_hash ON link_notices(link_hash); + +ALTER TABLE group_members ADD COLUMN member_restriction_expires_at TIMESTAMPTZ; +ALTER TABLE group_members ADD COLUMN member_restriction_by_user SMALLINT NOT NULL DEFAULT 0; + +CREATE INDEX idx_group_members_member_restriction_expires_at ON group_members(member_restriction_expires_at); |] down_m20261020_link_notices :: Text down_m20261020_link_notices = [r| +DROP INDEX idx_group_members_member_restriction_expires_at; + +ALTER TABLE group_members DROP COLUMN member_restriction_by_user; +ALTER TABLE group_members DROP COLUMN member_restriction_expires_at; + DROP INDEX idx_link_notices_link_hash; DROP TABLE link_notices; |] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20261020_link_notices.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20261020_link_notices.hs index 0cc69d6e8f..f3b9bd2799 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20261020_link_notices.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20261020_link_notices.hs @@ -12,17 +12,26 @@ CREATE TABLE link_notices( link_notice_id INTEGER PRIMARY KEY AUTOINCREMENT, link_hash BLOB NOT NULL, expires_at TEXT, - reason TEXT, created_at TEXT NOT NULL, updated_at TEXT NOT NULL ) STRICT; CREATE UNIQUE INDEX idx_link_notices_link_hash ON link_notices(link_hash); + +ALTER TABLE group_members ADD COLUMN member_restriction_expires_at TEXT; +ALTER TABLE group_members ADD COLUMN member_restriction_by_user INTEGER NOT NULL DEFAULT 0; + +CREATE INDEX idx_group_members_member_restriction_expires_at ON group_members(member_restriction_expires_at); |] down_m20261020_link_notices :: Query down_m20261020_link_notices = [sql| +DROP INDEX idx_group_members_member_restriction_expires_at; + +ALTER TABLE group_members DROP COLUMN member_restriction_by_user; +ALTER TABLE group_members DROP COLUMN member_restriction_expires_at; + DROP INDEX idx_link_notices_link_hash; DROP TABLE link_notices; |] diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index fa178494b6..f4163a5e04 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -36,7 +36,7 @@ import Data.Type.Equality import Simplex.Chat.Badges (BadgeRow, MaybeBadgeProofRow, ProofPresHeader, badgeToRow, maybeRowToBadgeProof, rowToBadge) import Simplex.Chat.Names (SimplexDomainProof, SimplexDomainClaim (..), claimDomain) import Simplex.Chat.Messages -import Simplex.Chat.Protocol (LinkNotice (..), ReportReason) +import Simplex.Chat.Protocol (LinkNotice (..)) import Simplex.Chat.Remote.Types import Simplex.Chat.Types import Simplex.Chat.Types.Preferences @@ -702,7 +702,7 @@ type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Text, Maybe type PublicGroupAccessRow = (Maybe Text, Maybe SimplexDomain, Maybe BoolInt, Maybe BoolInt, Maybe SimplexDomainProof) -type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId) :. ProfileRow :. (UTCTime, UTCTime) :. (Maybe UTCTime, Int64, Int64, Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact, Maybe Text, Maybe UTCTime) +type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, BoolInt, Maybe MemberRestrictionStatus, Maybe UTCTime) :.(Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId) :. ProfileRow :. (UTCTime, UTCTime) :. (Maybe UTCTime, Int64, Int64, Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact, Maybe Text, Maybe UTCTime) type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Text, Maybe Text) :. BadgeRow :. ContactDomainRow @@ -781,10 +781,10 @@ setUserMemberKey db groupId membershipId newKey = do pure memberPrivKey toGroupMember :: UTCTime -> Int64 -> GroupMemberRow -> GroupMember -toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) = +toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_, blockedUntil) :.(invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) = let memberProfile = rowToLocalProfile now profileRow memberSettings = GroupMemberSettings {showMessages} - blockedByAdmin = maybe False mrsBlocked memberRestriction_ + blockedByAdmin = blockedAt now memberRestriction_ blockedUntil invitedBy = toInvitedBy userContactId invitedById activeConn = Nothing memberVerifiedCode = SecurityCode <$> memberCode_ <*> memberCodeVerifiedAt_ @@ -807,7 +807,7 @@ groupMemberQuery :: Query groupMemberQuery = [sql| SELECT - m.group_member_id, m.group_id, m.index_in_group, 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.group_member_id, m.group_id, m.index_in_group, 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.member_restriction_expires_at, 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.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.preferences_json, p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, m.created_at, m.updated_at, @@ -854,7 +854,7 @@ groupInfoQueryFields = g.root_priv_key, g.root_pub_key, g.member_priv_key, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.index_in_group, 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, + mu.member_status, mu.show_messages, mu.member_restriction, mu.member_restriction_expires_at, 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.short_descr, pu.description, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, pu.preferences_json, pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.contact_domain, pu.contact_domain_proof, pu.contact_domain_verified, mu.created_at, mu.updated_at, @@ -1002,30 +1002,38 @@ setContactLinkNotice db ct brokerTs notice = >>= mapM_ (\linkHash -> upsertLinkNotice db linkHash brokerTs notice) upsertLinkNotice :: DB.Connection -> ConnReqUriHash -> UTCTime -> LinkNotice -> IO () -upsertLinkNotice db linkHash brokerTs LinkNotice {ttl, reason} = do +upsertLinkNotice db linkHash brokerTs LinkNotice {ttl} = do currentTs <- getCurrentTime + let expiresAt = capExpiry $ (\t -> addUTCTime (fromIntegral t) (min brokerTs currentTs)) <$> ttl DB.execute db [sql| - INSERT INTO link_notices (link_hash, expires_at, reason, created_at, updated_at) - VALUES (?,?,?,?,?) + INSERT INTO link_notices (link_hash, expires_at, created_at, updated_at) + VALUES (?,?,?,?) ON CONFLICT (link_hash) DO UPDATE SET expires_at = EXCLUDED.expires_at, - reason = EXCLUDED.reason, updated_at = EXCLUDED.updated_at |] - (linkHash, expiresAt, reason, currentTs, currentTs) - where - expiresAt = mfilter (< maxLinkNoticeExpiry) $ (\t -> addUTCTime (fromIntegral t) brokerTs) <$> ttl - maxLinkNoticeExpiry = UTCTime (fromGregorian 10000 1 1) 0 + (linkHash, expiresAt, currentTs, currentTs) -getLinkNotice :: DB.Connection -> UTCTime -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe (Maybe UTCTime, Maybe ReportReason)) +capExpiry :: Maybe UTCTime -> Maybe UTCTime +capExpiry = fmap (max minExpiry) . mfilter (< maxExpiry) + where + minExpiry = UTCTime (fromGregorian 1970 1 1) 0 + maxExpiry = UTCTime (fromGregorian 10000 1 1) 0 + +blockExpiry :: MemberRestrictions -> Maybe UTCTime +blockExpiry MemberRestrictions {restriction, expiresAt} + | mrsBlocked restriction = capExpiry expiresAt + | otherwise = Nothing + +getLinkNotice :: DB.Connection -> UTCTime -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe (Maybe UTCTime)) getLinkNotice db currentTs (linkHash1, linkHash2) = - maybeFirstRow id $ + maybeFirstRow fromOnly $ DB.query db [sql| - SELECT expires_at, reason + SELECT expires_at FROM link_notices WHERE link_hash IN (?,?) AND (expires_at IS NULL OR expires_at > ?) ORDER BY expires_at IS NULL DESC, expires_at DESC diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 94fd5d4fcd..d4209f28ce 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1162,14 +1162,18 @@ mrsBlocked = \case MRSBlocked -> True _ -> False +blockedAt :: UTCTime -> Maybe MemberRestrictionStatus -> Maybe UTCTime -> Bool +blockedAt now restriction_ blockedUntil = maybe False mrsBlocked restriction_ && maybe True (now <) blockedUntil + data MemberRestrictions = MemberRestrictions - { restriction :: MemberRestrictionStatus + { restriction :: MemberRestrictionStatus, + expiresAt :: Maybe UTCTime } deriving (Eq, Show) memberRestrictions :: GroupMember -> Maybe MemberRestrictions memberRestrictions m - | blockedByAdmin m = Just MemberRestrictions {restriction = MRSBlocked} + | blockedByAdmin m = Just MemberRestrictions {restriction = MRSBlocked, expiresAt = blockedUntil m} | otherwise = Nothing data ReceivedGroupInvitation = ReceivedGroupInvitation @@ -1194,6 +1198,7 @@ data GroupMember = GroupMember memberStatus :: GroupMemberStatus, memberSettings :: GroupMemberSettings, blockedByAdmin :: Bool, + blockedUntil :: Maybe UTCTime, invitedBy :: InvitedBy, invitedByGroupMemberId :: Maybe GroupMemberId, localDisplayName :: ContactName, @@ -1308,7 +1313,7 @@ data NewGroupMember = NewGroupMember { memInfo :: MemberInfo, memCategory :: GroupMemberCategory, memStatus :: GroupMemberStatus, - memRestriction :: Maybe MemberRestrictionStatus, + memRestriction :: Maybe MemberRestrictions, memInvitedBy :: InvitedBy, memInvitedByGroupMemberId :: Maybe GroupMemberId, localDisplayName :: ContactName, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 7f6ac72551..e86501f73d 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1472,7 +1472,7 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt GSMemCreator -> ["created group"] _ -> [] muted m - | blockedByAdmin m = ["blocked by admin"] + | blockedByAdmin m && memberRole' membership >= GRModerator = ["blocked by admin"] | not (showMessages $ memberSettings m) = ["blocked"] | otherwise = [] @@ -1892,10 +1892,8 @@ day = T.pack . formatTime defaultTimeLocale "%Y-%m-%d" dayTime :: UTCTime -> Text dayTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M" -viewLinkNotice :: Maybe UTCTime -> Maybe ReportReason -> Text -viewLinkNotice expiresAt reason = - maybe "banned permanently" (("banned until " <>) . dayTime) expiresAt - <> maybe "" ((", reason: " <>) . safeDecodeUtf8 . strEncode) reason +viewLinkNotice :: Maybe UTCTime -> Text +viewLinkNotice = maybe "banned permanently" (("banned until " <>) . dayTime) viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString] viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink, localBadge, contactDomain, contactDomainVerified, description}, activeConn, uiThemes, customData} stats incognitoProfile = @@ -2284,7 +2282,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case <> contactDomainLine ct <> ["use " <> ttyToContact' ct <> highlight' "" <> " to send messages"] CAPContactViaAddress ct -> [ctAddr ("known contact without connection " <> ttyContact' ct)] <> contactDomainLine ct - CAPLinkNotice expiresAt reason -> [ctAddr $ plain $ viewLinkNotice expiresAt reason] + CAPLinkNotice expiresAt _ -> [ctAddr $ plain $ viewLinkNotice expiresAt] where ctAddr = ("contact address: " <>) addrOrBiz = \case @@ -2319,7 +2317,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case knownGroup prepared = grpOrBizLink g <> ": known " <> prepared <> grpOrBiz g <> " " <> ttyGroup' g GLPNoRelays _ -> [grpLink "channel has no active relays, please try to join later"] GLPUpdateRequired _ -> [grpLink "this group requires a newer version of the app, please upgrade"] - GLPLinkNotice expiresAt reason -> [grpLink $ plain $ viewLinkNotice expiresAt reason] + GLPLinkNotice expiresAt -> [grpLink $ plain $ viewLinkNotice expiresAt] where connecting g = [grpOrBizLink g <> ": connecting to " <> grpOrBiz g <> " " <> ttyGroup' g] grpLink = ("group link: " <>) @@ -2828,7 +2826,7 @@ viewChatError isCmd logLevel testView = \case <> maybe "" (\MsgMetaJSON {rcvId} -> ", agent msg rcv id: " <> show rcvId) msgMeta_ ] CEConnReqMessageProhibited -> ["message is not allowed with this connection link"] - CELinkNotice expiresAt reason -> ["connection link: " <> plain (viewLinkNotice expiresAt reason)] + CELinkNotice expiresAt -> ["connection link: " <> plain (viewLinkNotice expiresAt)] CEContactNotFound cName m_ -> viewContactNotFound cName m_ CEContactNotReady c -> [ttyContact' c <> ": not ready"] CEContactDisabled ct -> [ttyContact' ct <> ": disabled, to enable: " <> highlight ("/enable " <> viewContactName ct) <> ", to delete: " <> highlight ("/d " <> viewContactName ct)] diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index bbb45cc1fb..dc88371cdc 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -68,6 +68,7 @@ chatDirectTests = do it "delete contact keeping conversation" testDeleteContactKeepConversation it "delete conversation keeping contact" testDeleteConversationKeepContact it "delete contact connected via invitation with notice" testDeleteContactInvitationNotice + it "archive contact" testArchiveContact it "direct message quoted replies" testDirectMessageQuotedReply it "direct message update" testDirectMessageUpdate it "direct message edit history" testDirectMessageEditHistory @@ -616,9 +617,44 @@ testDeleteContactInvitationNotice = alice <## "bad chat command: notice requires deleting the contact" alice ##> "/_delete @2 full notice={\"ttl\":86400}" alice <## "bob: contact is deleted" - bob <## "alice (Alice) deleted contact with you" + bob TestParams -> IO () +testArchiveContact = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + alice <##> bob + + alice ##> "/_delete @2 archive notice={}" + alice <## "bad chat command: notice requires deleting the contact" + alice ##> "/_delete @2 archive" + alice <## "bob: contact is deleted" + chatDeleted alice `shouldReturn` True + alice #$> ("/_get chat @2 count=1", chat, [(0, "hey")]) + + bob #> "@alice hi" + alice <# "bob> hi" + chatDeleted alice `shouldReturn` False + + alice ##> "/_delete @2 entity notify=off" + alice <## "bob: contact is deleted" + alice ##> "/_delete @2 archive" + alice <## "bob: contact is deleted" + chatDeleted alice `shouldReturn` True + alice #$> ("/_get chat @2 count=1", chat, [(0, "hi")]) + + alice ##> "/c" + _ <- getInvitation alice + connId <- withCCTransaction alice $ \db -> (\[Only i] -> i :: Int) <$> DB.query_ db "SELECT max(connection_id) FROM connections" + alice ##> ("/_delete :" <> show connId <> " archive") + alice <## "bad chat command: archive is not supported for pending connections" + where + chatDeleted cc = + withCCTransaction cc $ \db -> + (\[Only (DB.BI d)] -> d) <$> DB.query_ db "SELECT chat_deleted FROM contacts WHERE contact_id = 2" + testDeleteConversationKeepContact :: HasCallStack => TestParams -> IO () testDeleteConversationKeepContact = testChat2 aliceProfile bobProfile $ diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 40a9375606..85ab3cf270 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -151,6 +151,10 @@ chatGroupTests = do it "removal notice applies only to the link used to join" testPlanGroupLinkRemovedNoticeOtherLinks it "group deletion without notice leaves notices unchanged" testPlanGroupLinkDeletedWithoutNotice it "rejected pending member with notice can't re-join" testPlanGroupLinkRejectedNotice + it "removed admin with notice sees removal and can't re-join" testPlanGroupLinkRemovedAdminNotice + it "removal with notice of a member on previous version is prohibited" $ + runTestCfg2 testCfg testCfgVPrev testRemoveMemberNoticePrevVersion + it "group deleted with kept conversation" testGroupDeleteKeepConversation #if !defined(dbPostgres) -- TODO [postgres] restore from outdated db backup (same as in agent) describe "group message errors" $ do @@ -248,6 +252,10 @@ chatGroupTests = do it "block left/removed members" testBlockForAllLeftRemoved it "mentions of blocked member are ignored" testBlockForAllMentionsIgnored it "replies of blocked member are not mentions" testBlockedMemberReplyNotMention + it "timed block ends at the end time" testBlockForAllTimed + it "member who set the block sends unblock after the end time" $ + runTestCfg3 blockCleanupCfg testCfg testCfgVPrev testBlockForAllExpiryCleanup + it "blocked pending member can't be accepted" testBlockPendingMember describe "group member inactivity" $ do it "mark member inactive on reaching quota" testGroupMemberInactive describe "group member reports" $ do @@ -3108,27 +3116,32 @@ testPlanGroupLinkRemovedNotice = gLink <- createTeamLink alice joinTeamViaLink alice bob gLink "bob" - alice ##> "/rm team bob notice={\"ttl\":86400,\"reason\":\"spam\"}" - removedFromTeam alice bob "bob" + alice ##> "/rm team bob notice={\"ttl\":86400}" + silentlyRemovedFromTeam alice bob "bob" 1 bob ##> ("/_connect plan 1 " <> gLink) - bannedLine bob "group link: " ", reason: spam" - bob ##> ("/_connect plan 1 " <> linkAnotherSchema gLink) - bannedLine bob "group link: " ", reason: spam" + bob <## "group link: known group #team" + bob <## "use #team to send messages" bob ##> ("/c " <> gLink) - bannedLine bob "group link: " ", reason: spam" - bob ##> ("/_connect 1 " <> gLink) - bannedLine bob "connection link: " ", reason: spam" + bob <## "group link: known group #team" + bob <## "use #team to send messages" + bob #> "#team hello" + alice "/d #team" - bob <## "#team: you deleted your local copy of the group" + leaveDeleteTeam bob bob ##> ("/_connect plan 1 " <> gLink) - bannedLine bob "group link: " ", reason: spam" + bannedLine bob "group link: " + bob ##> ("/_connect plan 1 " <> linkAnotherSchema gLink) + bannedLine bob "group link: " + bob ##> ("/c " <> gLink) + bannedLine bob "group link: " + bob ##> ("/_connect 1 " <> gLink) + bannedLine bob "connection link: " bob ##> "/create user robert" showActiveUser bob "robert" bob ##> ("/_connect plan 2 " <> gLink) - bannedLine bob "group link: " ", reason: spam" + bannedLine bob "group link: " testPlanGroupLinkRemovedNoticeReplaced :: HasCallStack => TestParams -> IO () testPlanGroupLinkRemovedNoticeReplaced = @@ -3149,20 +3162,22 @@ testPlanGroupLinkRemovedNoticeReplaced = joinTeamViaLink alice bob gLink "bob_1" alice ##> "/rm team bob_1 notice={\"ttl\":0}" - removedFromTeam alice bob "bob_1" + silentlyRemovedFromTeam alice bob "bob_1" 1 + leaveDeleteTeam bob bob ##> ("/_connect plan 1 " <> gLink) bob <## "group link: ok to connect directly" _sLinkData <- getTermLine bob linkNoticesCount bob `shouldReturn` 1 - bob ##> "/d #team" - bob <## "#team: you deleted your local copy of the group" joinTeamViaLink alice bob gLink "bob_2" - alice ##> "/rm team bob_2 notice={\"reason\":\"profile\"}" - removedFromTeam alice bob "bob_2" + alice ##> "/rm team bob_2 notice={}" + alice <## "#team: you removed bob_2 from the group (signed)" + permanentLinkNoticesCount bob `shouldEventuallyReturn` 1 + bob ("/_connect plan 1 " <> gLink) - bob <## "group link: banned permanently, reason: profile" + bob <## "group link: banned permanently" linkNoticesCount bob `shouldReturn` 1 testPlanGroupLinkRemovedNoticeOtherLinks :: HasCallStack => TestParams -> IO () @@ -3178,9 +3193,10 @@ testPlanGroupLinkRemovedNoticeOtherLinks = clubLink <- getGroupLink alice "club" GRMember True alice ##> "/rm team bob notice={\"ttl\":86400}" - removedFromTeam alice bob "bob" + silentlyRemovedFromTeam alice bob "bob" 1 + leaveDeleteTeam bob bob ##> ("/_connect plan 1 " <> gLink) - bannedLine bob "group link: " "" + bannedLine bob "group link: " bob ##> ("/_connect plan 1 " <> clubLink) bob <## "group link: ok to connect directly" _sLinkData <- getTermLine bob @@ -3225,16 +3241,73 @@ testPlanGroupLinkRejectedNotice = bob <## "#team: you joined the group, pending approval" ] - alice ##> "/rm team bob notice={\"ttl\":3600,\"reason\":\"community\"}" - alice <## "#team: you removed bob from the group (signed)" - bob <## "#team: alice removed you from the group (signed)" - bob <## "use /d #team to delete the group" + alice ##> "/rm team bob notice={\"ttl\":3600}" + silentlyRemovedFromTeam alice bob "bob" 1 + leaveDeleteTeam bob bob ##> ("/_connect plan 1 " <> gLink) - bannedLine bob "group link: " ", reason: community" + bannedLine bob "group link: " where cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Right (GAPendingApproval, GRObserver))}} +testPlanGroupLinkRemovedAdminNotice :: HasCallStack => TestParams -> IO () +testPlanGroupLinkRemovedAdminNotice = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + gLink <- createTeamLink alice + joinTeamViaLink alice bob gLink "bob" + alice ##> "/mr team bob admin" + alice <## "#team: you changed the role of bob to admin (signed)" + bob <## "#team: alice changed your role from member to admin (signed)" + + alice ##> "/rm team bob notice={\"ttl\":86400}" + removedFromTeam alice bob "bob" + linkNoticesCount bob `shouldReturn` 1 + bob ##> "/d #team" + bob <## "#team: you deleted your local copy of the group" + bob ##> ("/_connect plan 1 " <> gLink) + bannedLine bob "group link: " + +testRemoveMemberNoticePrevVersion :: HasCallStack => TestCC -> TestCC -> IO () +testRemoveMemberNoticePrevVersion alice bob = do + createGroup2' "team" alice (bob, GRMember) True + alice ##> "/rm team bob notice={}" + alice <## "bad chat command: notice is not supported for relays, members on old versions and members not in the group" + alice ##> "/rm team bob" + concurrentlyN_ + [ alice <## "#team: you removed bob from the group (signed)", + do + bob <## "#team: alice removed you from the group (signed)" + bob <## "use /d #team to delete the group" + ] + +testGroupDeleteKeepConversation :: HasCallStack => TestParams -> IO () +testGroupDeleteKeepConversation = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + createGroup2' "team" alice (bob, GRMember) True + alice #> "#team hi" + bob <# "#team alice> hi" + + bob ##> "/_delete #1 entity" + bob <## "#team: you have insufficient permissions for this action, the required role is owner" + alice ##> "/_delete #1 archive" + alice <## "bad chat command: only full deletion or keeping the conversation is supported for groups" + alice ##> "/_delete #1 messages" + alice <## "bad chat command: only full deletion or keeping the conversation is supported for groups" + + alice ##> "/_delete #1 entity" + alice <## "#team: you deleted the group (signed)" + bob <## "#team: alice deleted the group (signed)" + bob <## "use /d #team to delete the local copy of the group" + alice #$> ("/_get chat #1 count=1", chat, [(1, "hi")]) + alice ##> "#team hello" + alice <## "bad chat command: not current member" + alice ##> "/_delete #1 entity" + alice <## "bad chat command: keeping the conversation requires an active owner" + alice ##> "/d #team" + alice <## "#team: you deleted your local copy of the group" + createTeamLink :: HasCallStack => TestCC -> IO String createTeamLink alice = do threadDelay 100000 @@ -3267,6 +3340,20 @@ removedFromTeam alice bob bobName = bob <## "use /d #team to delete the group" ] +silentlyRemovedFromTeam :: HasCallStack => TestCC -> TestCC -> String -> Int -> IO () +silentlyRemovedFromTeam alice bob bobName noticesCount = do + alice <## ("#team: you removed " <> bobName <> " from the group (signed)") + waitLinkNoticesCount bob noticesCount + bob TestCC -> IO () +leaveDeleteTeam bob = do + bob ##> "/l team" + bob <## "#team: you left the group" + bob <## "use /d #team to delete the group" + bob ##> "/d #team" + bob <## "#team: you deleted your local copy of the group" + testGroupLinkLargeGroupProfile :: HasCallStack => TestParams -> IO () testGroupLinkLargeGroupProfile = testChatOpts2 testOptsNoFullLinks aliceProfile bobProfile $ @@ -8184,12 +8271,14 @@ testBlockForAllMultipleMembers = -- bob and cath don't know they are blocked and receive each other's messages bob #> "#team 3" - [alice, dan] *<# "#team bob> 3 [blocked by admin] " + alice <# "#team bob> 3 [blocked by admin] " cath <# "#team bob> 3" + dan "#team 4" - [alice, dan] *<# "#team cath> 4 [blocked by admin] " + alice <# "#team cath> 4 [blocked by admin] " bob <# "#team cath> 4" + dan "/_block #1 2,3 blocked=off" alice <## "#team: you unblocked 2 members (signed)" @@ -8204,6 +8293,112 @@ testBlockForAllMultipleMembers = cath #> "#team 6" [alice, bob, dan] *<# "#team cath> 6" +testBlockForAllTimed :: HasCallStack => TestParams -> IO () +testBlockForAllTimed = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3' "team" alice (bob, GRMember) (cath, GRMember) + threadDelay 1000000 + alice #> "#team hi" + [bob, cath] *<# "#team alice> hi" + + alice ##> "/block for all #team bob ttl=4" + alice <## "#team: you blocked bob (signed)" + cath <## "#team: alice blocked bob (signed)" + bob "/ms team" + alice + <### [ "alice (Alice): owner, you, created group", + "bob (Bob): member, invited, connected, blocked by admin", + "cath (Catherine): member, invited, connected" + ] + cath ##> "/ms team" + cath + <### [ "cath (Catherine): member, you, connected", + "alice (Alice): owner, host, connected", + "bob (Bob): member, connected" + ] + + bob #> "#team 1" + alice <# "#team bob> 1 [blocked by admin] " + cath ("/_get chat #1 count=2", chat, [(1, "blocked bob (signed)"), (0, "1 [blocked by admin]")]) + cath #$> ("/_get chat #1 count=1", chat, [(0, "hi")]) + + threadDelay 4000000 + bob #> "#team 2" + [alice, cath] *<# "#team bob> 2" + alice ##> "/ms team" + alice + <### [ "alice (Alice): owner, you, created group", + "bob (Bob): member, invited, connected", + "cath (Catherine): member, invited, connected" + ] + +testBlockForAllExpiryCleanup :: HasCallStack => TestCC -> TestCC -> TestCC -> IO () +testBlockForAllExpiryCleanup alice bob cath = do + createGroup3' "team" alice (bob, GRMember) (cath, GRMember) + threadDelay 1000000 + + alice ##> "/block for all #team cath" + alice <## "#team: you blocked cath (signed)" + bob <## "#team: alice blocked cath (signed)" + cath "/block for all #team bob ttl=2" + alice <## "#team: you blocked bob (signed)" + cath <## "#team: alice blocked bob (signed)" + bob ("/_get chat #1 count=3", chat, [(1, "blocked cath (signed)"), (1, "blocked bob (signed)"), (1, "unblocked bob (signed)")]) + threadDelay 2000000 + alice #$> ("/_get chat #1 count=1", chat, [(1, "unblocked bob (signed)")]) + alice ##> "/ms team" + alice + <### [ "alice (Alice): owner, you, created group", + "bob (Bob): member, invited, connected", + "cath (Catherine): member, invited, connected, blocked by admin" + ] + + bob #> "#team hi" + [alice, cath] *<# "#team bob> hi" + +blockCleanupCfg :: ChatConfig +blockCleanupCfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0} + +testBlockPendingMember :: HasCallStack => TestParams -> IO () +testBlockPendingMember = + testChatCfg2 cfg aliceProfile bobProfile $ + \alice bob -> do + gLink <- createTeamLink alice + bob ##> ("/c " <> gLink) + bob <## "connection request sent!" + alice <## "bob (Bob): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: bob connected and pending approval, use /_accept member #1 2 to accept member", + do + bob <## "#team: joining the group..." + bob <## "#team: you joined the group, pending approval" + ] + + alice ##> "/block for all #team bob" + alice <##. "#team: you blocked bob" + bob "/_accept member #1 2 member" + alice <## "bad chat command: can't accept blocked member, unblock first" + + alice ##> "/unblock for all #team bob" + alice <##. "#team: you unblocked bob" + alice ##> "/_accept member #1 2 member" + concurrentlyN_ + [ alice <## "#team: bob accepted", + bob <## "#team: you joined the group" + ] + where + cfg = testCfg {chatHooks = defaultChatHooks {acceptMember = Just (\_ _ _ -> pure $ Right (GAPendingApproval, GRObserver))}} + testBlockForAllLeftRemoved :: HasCallStack => TestParams -> IO () testBlockForAllLeftRemoved = testChat4 aliceProfile bobProfile cathProfile danProfile $ @@ -10905,10 +11100,10 @@ testChannelBlockMemberSigned ps = eve <## "#team: alice blocked cath (signed)" ] alice #$> ("/_get chat #1 count=1", chat, [(1, "blocked cath (signed)")]) - bob #$> ("/_get chat #1 count=1", chat, [(0, "blocked cath (signed)")]) + bob #$> ("/_get chat #1 count=1", chat, [(0, "hello from cath")]) cath #$> ("/_get chat #1 count=1", chat, [(1, "hello from cath")]) -- was blocked - no "blocked" chat item - dan #$> ("/_get chat #1 count=1", chat, [(0, "blocked cath (signed)")]) - eve #$> ("/_get chat #1 count=1", chat, [(0, "blocked cath (signed)")]) + dan #$> ("/_get chat #1 count=1", chat, [(0, "hello from cath")]) + eve #$> ("/_get chat #1 count=1", chat, [(0, "hello from cath")]) -- TODO [relays] member: in channels - don't create unknown member record and chat item? (just ignore) -- block silent member (other members create unknown member record and can verify) @@ -10925,16 +11120,10 @@ testChannelBlockMemberSigned ps = eve .<##. ("#team: alice blocked", "(signed)") ] alice #$> ("/_get chat #1 count=1", chat, [(1, "blocked dan (signed)")]) - bob #$> ("/_get chat #1 count=1", chat, [(0, "blocked dan (signed)")]) - cath ##> "/_get chat #1 count=1" - [(0, r1)] <- chat <$> getTermLine cath - r1 `shouldStartWith` "blocked" - r1 `shouldEndWith` "(signed)" - dan #$> ("/_get chat #1 count=1", chat, [(0, "blocked cath (signed)")]) -- was blocked - no new chat item - eve ##> "/_get chat #1 count=1" - [(0, r2)] <- chat <$> getTermLine eve - r2 `shouldStartWith` "blocked" - r2 `shouldEndWith` "(signed)" + bob #$> ("/_get chat #1 count=1", chat, [(0, "hello from cath")]) + cath #$> ("/_get chat #1 count=1", chat, [(1, "hello from cath")]) + dan #$> ("/_get chat #1 count=1", chat, [(0, "hello from cath")]) + eve #$> ("/_get chat #1 count=1", chat, [(0, "hello from cath")]) checkMemberRow :: HasCallStack => TestCC -> T.Text -> Maybe T.Text -> IO () checkMemberRow cc name expectedRole = memberRoles cc name `shouldReturn` maybeToList expectedRole @@ -11443,16 +11632,25 @@ testChannelRemoveMemberNotice ps = memberJoinChannel "team" [bob] [alice] shortLink fullLink cath threadDelay 1000000 - alice ##> "/rm #team cath notice={\"ttl\":86400,\"reason\":\"content\"}" + alice ##> "/rm #team cath notice={\"ttl\":86400}" alice <## "#team: you removed cath from the group (signed)" bob <## "#team: alice removed cath from the group (signed)" - cath <## "#team: alice removed you from the group (signed)" - cath <## "use /d #team to delete the group" + waitLinkNoticesCount cath 1 + cath ("/_connect plan 1 " <> shortLink) - bannedLine cath "group link: " ", reason: content" + cath <## "group link: known group #team" + cath <## "use #team to send messages" cath ##> "/_connect group #1" - bannedLine cath "connection link: " ", reason: content" + bannedLine cath "connection link: " + + cath ##> "/l #team" + cath <## "#team: you left the group" + cath <## "use /d #team to delete the group" + cath ##> "/d #team" + cath <## "#team: you deleted your local copy of the group" + cath ##> ("/_connect plan 1 " <> shortLink) + bannedLine cath "group link: " -- asserts the member row is GSMemRemoved, with removed_at set (TTL tombstone) or NULL (permanent) checkRemovedMember :: HasCallStack => TestCC -> String -> Bool -> Expectation diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 4f92e122f5..45eecc3ee0 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -126,7 +126,6 @@ chatProfileTests = do it "contact via address" testPlanAddressContactViaAddress it "contact via short address" testPlanAddressContactViaShortAddress it "contact deleted silently with notice can't re-connect" testPlanAddressContactDeletedNoticeSilent - it "contact deleted with notification and notice can't re-connect" testPlanAddressContactDeletedNoticeNotify it "silent notice is not sent to previous version" $ runTestCfg2 testCfg testCfgVPrev testPlanAddressContactDeletedNoticePrevVersion describe "incognito" $ do @@ -2160,26 +2159,38 @@ testBusinessAddressNotice = testChat3 businessProfile bobProfile cathProfile $ biz <## "auto_accept on, business" connectBusinessCustomer biz bob cLink "bob" "Bob" - biz ##> "/rm #bob bob_1 notice={\"ttl\":86400,\"reason\":\"spam\"}" + biz ##> "/rm #bob bob_1 notice={\"ttl\":86400}" biz <## "#bob: you removed bob_1 from the group (signed)" - bob <## "#biz: biz_1 removed you from the group (signed)" - bob <## "use /d #biz to delete the group" + waitLinkNoticesCount bob 1 + bob ("/_connect plan 1 " <> cLink) - bannedLine bob "contact address: " ", reason: spam" + bob <## "business address: known business #biz" + bob <## "use #biz to send messages" + leaveDeleteBiz bob + bob ##> ("/_connect plan 1 " <> cLink) + bannedLine bob "contact address: " bob ##> ("/_connect 1 " <> cLink) - bannedLine bob "connection link: " ", reason: spam" + bannedLine bob "connection link: " connectBusinessCustomer biz cath cLink "cath" "Catherine" - biz ##> "/_delete #2 full notice={\"reason\":\"other\"}" + biz ##> "/_delete #2 full notice={}" biz <## "#cath: you deleted the group (signed)" - cath <## "#biz: biz_1 deleted the group (signed)" - cath <## "use /d #biz to delete the local copy of the group" + waitLinkNoticesCount cath 1 + cath ("/_connect plan 1 " <> cLink) - cath <## "contact address: banned permanently, reason: other" + cath <## "contact address: banned permanently" cath ##> ("/c " <> cLink) - cath <## "contact address: banned permanently, reason: other" + cath <## "contact address: banned permanently" cath ##> ("/_connect 1 " <> cLink) - cath <## "connection link: banned permanently, reason: other" + cath <## "connection link: banned permanently" + where + leaveDeleteBiz cc = do + cc ##> "/l #biz" + cc <## "#biz: you left the group" + cc <## "use /d #biz to delete the group" + cc ##> "/d #biz" + cc <## "#biz: you deleted your local copy of the group" connectBusinessCustomer :: HasCallStack => TestCC -> TestCC -> String -> String -> String -> IO () connectBusinessCustomer biz customer cLink name fullName = do @@ -2390,45 +2401,37 @@ testPlanAddressContactDeletedReconnected = testPlanAddressContactDeletedNoticeSilent :: HasCallStack => TestParams -> IO () testPlanAddressContactDeletedNoticeSilent = - testChat2 aliceProfile bobProfile $ - \alice bob -> do - cLink <- connectViaAddress alice bob - - alice ##> "/_delete @2 full notify=off notice={\"ttl\":86400,\"reason\":\"spam\"}" - alice <## "bob: contact is deleted" - waitLinkNoticesCount bob 1 - - bob ##> ("/_connect plan 1 " <> cLink) - bannedLine bob "contact address: " ", reason: spam" - bob ##> ("/_connect plan 1 " <> linkAnotherSchema cLink) - bannedLine bob "contact address: " ", reason: spam" - bob ##> ("/c " <> cLink) - bannedLine bob "contact address: " ", reason: spam" - bob ##> ("/_connect 1 " <> cLink) - bannedLine bob "connection link: " ", reason: spam" - bob @@@ [("@alice", "hey")] - -testPlanAddressContactDeletedNoticeNotify :: HasCallStack => TestParams -> IO () -testPlanAddressContactDeletedNoticeNotify = testChat2 aliceProfile bobProfile $ \alice bob -> do cLink <- connectViaAddress alice bob alice ##> "/_delete @2 full notice={\"ttl\":86400}" alice <## "bob: contact is deleted" - bob <## "alice (Alice) deleted contact with you" + waitLinkNoticesCount bob 1 + bob ("/_connect plan 1 " <> cLink) - bannedLine bob "contact address: " "" - linkNoticesCount bob `shouldReturn` 1 + bob <## "contact address: known contact alice" + bob <## "use @alice to send messages" + bob @@@ [("@alice", "hey")] + + bob ##> "/d alice" + bob <## "alice: contact is deleted" + bob ##> ("/_connect plan 1 " <> cLink) + bannedLine bob "contact address: " + bob ##> ("/_connect plan 1 " <> linkAnotherSchema cLink) + bannedLine bob "contact address: " + bob ##> ("/c " <> cLink) + bannedLine bob "contact address: " + bob ##> ("/_connect 1 " <> cLink) + bannedLine bob "connection link: " testPlanAddressContactDeletedNoticePrevVersion :: HasCallStack => TestCC -> TestCC -> IO () testPlanAddressContactDeletedNoticePrevVersion alice bob = do cLink <- connectViaAddress alice bob alice ##> "/_delete @2 full notify=off notice={\"ttl\":86400}" - alice <## "bob: contact is deleted" - threadDelay 500000 + alice <## "bad chat command: contact does not support notice" bob ##> ("/_connect plan 1 " <> cLink) bob <## "contact address: known contact alice" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 126b6a7765..28490ecc4b 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -696,11 +696,16 @@ waitLinkNoticesCount cc n = go (50 :: Int) then count `shouldBe` n else threadDelay 100000 >> go (attempts - 1) -bannedLine :: HasCallStack => TestCC -> String -> String -> Expectation -bannedLine cc prefix suffix = do +permanentLinkNoticesCount :: TestCC -> IO Int +permanentLinkNoticesCount cc = + withCCTransaction cc $ \db -> + fromMaybe 0 <$> maybeFirstRow fromOnly (DB.query_ db "SELECT count(1) FROM link_notices WHERE expires_at IS NULL") + +bannedLine :: HasCallStack => TestCC -> String -> Expectation +bannedLine cc prefix = do l <- getTermLine' (Just $ "banned: " <> prefix) cc - let banned = (prefix <> "banned until ") `isPrefixOf` l && suffix `isSuffixOf` l - unless banned $ print ("expected banned line: " <> prefix <> "... " <> suffix, ", got: " <> l) + let banned = (prefix <> "banned until ") `isPrefixOf` l + unless banned $ print ("expected banned line: " <> prefix <> "..., got: " <> l) banned `shouldBe` True shouldEventuallyReturn :: (HasCallStack, Eq a, Show a) => IO a -> a -> Expectation diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 036ecd10e8..03da780f1a 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -296,9 +296,6 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (mcQuote quotedMsg (MCReport "" RRSpam))) - it "x.msg.new report with illegal reason" $ - "{\"v\":\"9\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"\",\"reason\":\"illegal\",\"type\":\"report\"}}}" - ==# XMsgNew (mcSimple (MCReport "" RRContent)) it "x.msg.new forward with file" $ "{\"v\":\"9\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"},\"forward\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ (mcForward Nothing (MCText "hello")) {file = Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing, fileBadge = Nothing}}) @@ -376,7 +373,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro with member restrictions" $ "{\"v\":\"9\",\"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, memberKey = Nothing} (Just MemberRestrictions {restriction = MRSBlocked}) + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} (Just MemberRestrictions {restriction = MRSBlocked, expiresAt = Nothing}) + it "x.grp.mem.intro with timed member restrictions" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberRestrictions\":{\"restriction\":\"blocked\",\"expiresAt\":\"1970-01-01T00:00:01.000000001Z\"},\"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, memberKey = Nothing} (Just MemberRestrictions {restriction = MRSBlocked, expiresAt = Just $ systemToUTCTime $ MkSystemTime 1 1}) it "x.grp.mem.inv" $ "{\"v\":\"9\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"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-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}" #==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq} @@ -394,31 +394,40 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpMemConAll (MemberId "\1\2\3\4") it "x.grp.mem.del" $ "{\"v\":\"9\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\"}}" - #==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing Nothing - it "x.grp.mem.del with notice" $ - "{\"v\":\"9\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\",\"notice\":{\"ttl\":86400,\"reason\":\"spam\"}}}" - #==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing (Just LinkNotice {ttl = Just 86400, reason = Just RRSpam}) + #==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing False Nothing + it "x.grp.mem.del silent" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\",\"silent\":true}}" + #==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing True Nothing + it "x.grp.mem.del silent with notice" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\",\"silent\":true,\"notice\":{\"ttl\":86400}}}" + #==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing True (Just LinkNotice {ttl = Just 86400}) + it "x.grp.mem.del with permanent notice" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\",\"messages\":true,\"silent\":true,\"notice\":{}}}" + #==# XGrpMemDel (MemberId "\1\2\3\4") True Nothing True (Just LinkNotice {ttl = Nothing}) it "x.grp.mem.del with malformed notice" $ "{\"v\":\"9\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\",\"notice\":{\"ttl\":\"day\"}}}" - ==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing Nothing + ==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing False Nothing + it "x.grp.mem.restrict" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.restrict\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberRestrictions\":{\"restriction\":\"blocked\"}}}" + #==# XGrpMemRestrict (MemberId "\1\2\3\4") MemberRestrictions {restriction = MRSBlocked, expiresAt = Nothing} + it "x.grp.mem.restrict with end time" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.restrict\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberRestrictions\":{\"restriction\":\"blocked\",\"expiresAt\":\"1970-01-01T00:00:01.000000001Z\"}}}" + #==# XGrpMemRestrict (MemberId "\1\2\3\4") MemberRestrictions {restriction = MRSBlocked, expiresAt = Just $ systemToUTCTime $ MkSystemTime 1 1} + it "x.grp.mem.restrict automatic unblock" $ + "{\"v\":\"9\",\"event\":\"x.grp.mem.restrict\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberRestrictions\":{\"restriction\":\"unrestricted\",\"expiresAt\":\"1970-01-01T00:00:01.000000001Z\"}}}" + #==# XGrpMemRestrict (MemberId "\1\2\3\4") MemberRestrictions {restriction = MRSUnrestricted, expiresAt = Just $ systemToUTCTime $ MkSystemTime 1 1} it "x.grp.leave" $ "{\"v\":\"9\",\"event\":\"x.grp.leave\",\"params\":{}}" ==# XGrpLeave it "x.grp.del" $ "{\"v\":\"9\",\"event\":\"x.grp.del\",\"params\":{}}" - ==# XGrpDel Nothing - it "x.grp.del with notice" $ - "{\"v\":\"9\",\"event\":\"x.grp.del\",\"params\":{\"notice\":{\"reason\":\"content\"}}}" - #==# XGrpDel (Just LinkNotice {ttl = Nothing, reason = Just RRContent}) - it "x.grp.del with malformed notice" $ - "{\"v\":\"9\",\"event\":\"x.grp.del\",\"params\":{\"notice\":1}}" - ==# XGrpDel Nothing + ==# XGrpDel it "x.direct.del" $ "{\"v\":\"9\",\"event\":\"x.direct.del\",\"params\":{}}" #==# XDirectDel False Nothing it "x.direct.del silent with notice" $ "{\"v\":\"9\",\"event\":\"x.direct.del\",\"params\":{\"silent\":true,\"notice\":{\"ttl\":3600}}}" - #==# XDirectDel True (Just LinkNotice {ttl = Just 3600, reason = Nothing}) + #==# XDirectDel True (Just LinkNotice {ttl = Just 3600}) it "x.direct.del with malformed notice" $ "{\"v\":\"9\",\"event\":\"x.direct.del\",\"params\":{\"notice\":\"spam\"}}" ==# XDirectDel False Nothing