From 69fdc1c27fbdf975054f0e01382e8dd3bda6cd24 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 27 May 2026 19:23:31 +0400 Subject: [PATCH] wip --- src/Simplex/Chat/Library/Commands.hs | 5 +- src/Simplex/Chat/Library/Internal.hs | 26 +-- src/Simplex/Chat/Library/Subscriber.hs | 22 +- src/Simplex/Chat/Store/Messages.hs | 4 + src/Simplex/Chat/Types/Preferences.hs | 33 ++- src/Simplex/Chat/View.hs | 6 +- tests/ChatTests/Groups.hs | 277 +++++++++++++++++++++++++ tests/ChatTests/Utils.hs | 3 + 8 files changed, 348 insertions(+), 28 deletions(-) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 30502de904..c00c17cc5e 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -645,7 +645,10 @@ processChatCommand vr nm = \case forM_ quotedItemId $ \qId -> unlessM (withFastStore' $ \db -> quotedItemInCommentSection db parentItemId qId) $ throwCmdError "quoted item does not belong to the same comment section" - sendGroupContentMessages user gInfo Nothing False (Just channelMsgInfo) live itemTTL cmrs + -- Pass asGroup through so a channel owner can comment as the + -- channel rather than as themselves — that path renders for + -- subscribers as CIChannelRcv (no owner-member attribution). + sendGroupContentMessages user gInfo Nothing asGroup (Just channelMsgInfo) live itemTTL cmrs APISetCommentsDisabled groupId parentItemId disabled -> withUser $ \user -> withGroupLock "setCommentsDisabled" groupId $ do gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index d3e619d97e..3c2f98f528 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -2694,13 +2694,14 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do cup' = getContactUserPreference f cups' createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM () -createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = - forM_ allGroupFeatures $ \(AGF f) -> do - let state = groupFeatureState $ getGroupPreference f gps - pref' = getGroupPreference f gps' - state'@(_, param', role') = groupFeatureState pref' - when (state /= state') $ - createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing +createGroupFeatureChangedItems user cd ciContent gInfo GroupInfo {fullGroupPreferences = gps'} = + let GroupInfo {fullGroupPreferences = gps} = gInfo + in forM_ (groupFeaturesForChannel (useRelays' gInfo)) $ \(AGF f) -> do + let state = groupFeatureState $ getGroupPreference f gps + pref' = getGroupPreference f gps' + state'@(_, param', role') = groupFeatureState pref' + when (state /= state') $ + createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} @@ -2709,11 +2710,12 @@ createGroupFeatureItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d - createGroupFeatureItems user cd ciContent g = createGroupFeatureItems_ user cd False ciContent g >>= toView . CEvtNewChatItems user createGroupFeatureItems_ :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> ShowGroupAsSender -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM [AChatItem] -createGroupFeatureItems_ user cd showGroupAsSender ciContent GroupInfo {fullGroupPreferences} = - forM allGroupFeatures $ \(AGF f) -> do - let p = getGroupPreference f fullGroupPreferences - (_, param, role) = groupFeatureState p - createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing +createGroupFeatureItems_ user cd showGroupAsSender ciContent gInfo = + let GroupInfo {fullGroupPreferences} = gInfo + in forM (groupFeaturesForChannel (useRelays' gInfo)) $ \(AGF f) -> do + let p = getGroupPreference f fullGroupPreferences + (_, param, role) = groupFeatureState p + createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM () createInternalChatItem user cd content itemTs_ = do diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index c2f1100e7f..aa878a753e 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -2076,11 +2076,23 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newGroupContentMessage :: GroupInfo -> Maybe GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryTaskContext) newGroupContentMessage gInfo m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = case m_ of Nothing - -- Comments must have an author (a member, not the channel-as-sender). - -- A relay-forwarded message without member identity but carrying - -- mc.parent is a protocol violation — drop it rather than silently - -- discarding the parent reference and storing it as a channel post. - | isJust parent_ -> messageError "channel comment without author (FwdChannel)" $> Nothing + -- A relay-forwarded message arrives without member identity in two + -- legitimate cases: (1) the channel post itself (parent = Nothing, + -- asGroup = Just True) and (2) a comment posted by the channel + -- owner as the channel (parent = Just _, asGroup = Just True), which + -- stores at the receiver as CIChannelRcv with no member attribution. + -- A message that has parent set but is NOT asGroup is a protocol + -- violation — a member comment should arrive with FwdMember, not + -- FwdChannel — and is dropped. + | isJust parent_ && asGroup_ /= Just True -> + messageError "channel comment without author (FwdChannel)" $> Nothing + | isJust parent_ -> do + channelMsgInfo_ <- resolveCommentParent gInfo parent_ + case channelMsgInfo_ of + Just _ -> do + createContentItem gInfo Nothing Nothing channelMsgInfo_ + pure Nothing + Nothing -> pure Nothing | otherwise -> do createContentItem gInfo Nothing Nothing Nothing -- no delivery task - message already forwarded by relay diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 86d9498918..3db32414e0 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -1507,7 +1507,11 @@ adjustChannelMsgCommentCount :: DB.Connection -> ChatItemId -> Int -> IO () adjustChannelMsgCommentCount db parentChatItemId delta = DB.execute db +#if defined(dbPostgres) + "UPDATE chat_items SET comments_total = GREATEST(0, comments_total + ?) WHERE chat_item_id = ?" +#else "UPDATE chat_items SET comments_total = MAX(0, comments_total + ?) WHERE chat_item_id = ?" +#endif (delta, parentChatItemId) -- | Persist the per-post comments-disabled flag. diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index ee58009371..a8b6c8cef6 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -236,13 +236,16 @@ groupFeatureMemberAllowed' feature role prefs = let pref = getGroupPreference feature prefs in getField @"enable" pref == FEOn && maybe True (role >=) (getField @"role" pref) --- TODO: some preferences are channel-only (e.g., comments) and should not generate --- UI items or be configurable in regular groups. Currently they are simply excluded --- from this list. When more channel-only or group-only preferences are added, --- consider adding a scope property to GroupFeatureI (e.g., GFScopeAll | GFScopeChannel | GFScopeGroup) --- and filtering at the call sites in createGroupFeatureItems_ / createGroupFeatureChangedItems. +-- | All group features, used by serialization and full enumeration paths. +-- UI / feature-item paths must use 'groupFeaturesForChannel' so channel-only +-- features (currently just SGFComments) are not surfaced as preferences in +-- regular groups — see the failing test cases that depended on this filter. allGroupFeatures :: [AGroupFeature] -allGroupFeatures = +allGroupFeatures = commonGroupFeatures ++ channelOnlyGroupFeatures + +-- | Features that exist for every group type. +commonGroupFeatures :: [AGroupFeature] +commonGroupFeatures = [ AGF SGFTimedMessages, AGF SGFDirectMessages, AGF SGFFullDelete, @@ -252,10 +255,24 @@ allGroupFeatures = AGF SGFSimplexLinks, AGF SGFReports, AGF SGFHistory, - AGF SGFSupport, - AGF SGFComments + AGF SGFSupport ] +-- | Features that only exist in channel-style groups (useRelays' == True). +-- In regular groups these would render as meaningless ": off" items; +-- the per-group filter in 'groupFeaturesForChannel' drops them. +channelOnlyGroupFeatures :: [AGroupFeature] +channelOnlyGroupFeatures = + [ AGF SGFComments + ] + +-- | Features that apply to a given group. Pass True for channel groups +-- (i.e. @useRelays' gInfo@), False for regular groups. +groupFeaturesForChannel :: Bool -> [AGroupFeature] +groupFeaturesForChannel isChannel + | isChannel = allGroupFeatures + | otherwise = commonGroupFeatures + groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments} = case f of SGFTimedMessages -> timedMessages diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 477850d4b0..2d9fe749f2 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1974,7 +1974,9 @@ viewGroupUpdated | null prefs = [] | otherwise = bold' "updated group preferences:" : prefs where - prefs = mapMaybe viewPref allGroupFeatures + -- Filter to features applicable to this group type so channel-only + -- preferences (e.g. Comments) don't surface in regular-group updates. + prefs = mapMaybe viewPref (groupFeaturesForChannel (useRelays' g')) viewPref (AGF f) | pref gps == pref gps' = Nothing | otherwise = Just . plain $ groupPreferenceText (pref gps') @@ -1990,7 +1992,7 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {shortDescr, descripti <> maybe [] (\sd -> ["description: " <> plain sd]) shortDescr <> maybe [] (const ["has profile image"]) image <> maybe [] ((bold' "welcome message:" :) . map plain . T.lines) description - <> (bold' "group preferences:" : map viewPref allGroupFeatures) + <> (bold' "group preferences:" : map viewPref (groupFeaturesForChannel (useRelays' g))) where viewPref (AGF f) = plain $ groupPreferenceText (pref gps) where diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index c9ef5754f2..0f1218ada2 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -309,6 +309,12 @@ chatGroupTests = do it "owner should moderate-delete subscriber comment and decrement count" testChannelCommentModerationDelete it "content edit should preserve commentsDisabled flag" testChannelCommentDisabledViaPrefs it "subscriber should react to a channel comment" testChannelCommentReact + it "comment can quote another comment in the same thread" testChannelCommentQuoteAnotherComment + it "comment quoting another thread is rejected" testChannelCommentQuoteCrossThreadRejected + it "closing window rejects late comments" testChannelCommentClosingWindow + it "comments off at group preference rejects comments" testChannelCommentPrefOff + it "owner comment sent as group does not leak member identity" testChannelCommentOwnerSentAsGroupNoLeak + it "member demoted to observer cannot comment" testChannelCommentMemberCanCommentReceiveGuard testGroupCheckMessages :: HasCallStack => TestParams -> IO () testGroupCheckMessages = @@ -11431,6 +11437,277 @@ testChannelCommentReact ps = eve <## " + 👍" ] +-- | Override the comments preference on a single client's local view of a +-- group, simulating the result of an XGrpInfo propagation without invoking +-- the wire path (which on channels requires reconstructing the publicGroup +-- payload). Used by send-side preflight tests where the rejection happens +-- locally before the message leaves the client. +setLocalCommentsPref :: TestCC -> Int -> String -> Maybe Int -> IO () +setLocalCommentsPref cc gId enable closeAfterSec = do + let body = + "{\"directMessages\":{\"enable\":\"on\"}," + <> "\"history\":{\"enable\":\"on\"}," + <> "\"support\":{\"enable\":\"off\"}," + <> "\"comments\":{\"enable\":\"" + <> enable + <> "\"" + <> maybe "" (\n -> ",\"closeAfter\":" <> show n) closeAfterSec + <> "}}" + withCCTransaction cc $ \db -> + DB.execute + db + "UPDATE group_profiles SET preferences = ? WHERE group_profile_id = (SELECT group_profile_id FROM groups WHERE group_id = ?)" + (body, gId) + +testChannelCommentQuoteAnotherComment :: HasCallStack => TestParams -> IO () +testChannelCommentQuoteAnotherComment ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner posts a channel message + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- capture the parent post id BEFORE any intervening comments + -- so the later /_send can pass parent= safely. + postIdOnCath <- lastGroupItemId cath 1 + postIdOnDan <- lastGroupItemId dan 1 + + -- cath (member, can comment) posts the first comment. + cath ##> ("/_send #1 parent=" <> postIdOnCath <> " text first") + cath <# "#team first" + bob <# "#team cath> first" + concurrentlyN_ + [ alice <# "#team cath> first [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> first [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> first [>>]" + ] + + -- now cath's comment is the most recent item on dan's side. + cathCommentIdOnDan <- lastGroupItemId dan 1 + + -- dan sends a comment with both parent= (the post) and + -- quotedItemId (cath's comment). Wire carries both `parent` + -- and `quote` on the same MsgContainer. + -- Alice already knows dan (dan joined via alice's link) so no + -- "unknown member record" intro on alice. Cath and eve don't + -- know dan yet, so they get the intro. + let cm = "{\"msgContent\": {\"type\": \"text\", \"text\": \"reply to cath\"}, \"quotedItemId\": " <> cathCommentIdOnDan <> "}" + dan ##> ("/_send #1 parent=" <> postIdOnDan <> " json [" <> cm <> "]") + dan <# "#team > cath first" + dan <## " reply to cath" + bob <# "#team dan> > cath first" + bob <## " reply to cath" + concurrentlyN_ + [ do + alice <# "#team dan> > cath first [>>]" + alice <## " reply to cath [>>]", + do + cath <## "#team: bob forwarded a message from an unknown member, creating unknown member record dan" + -- cath's own text is the quoted item, hence the `dan!>` + -- attention marker on cath's view. + cath <# "#team dan!> > cath first [>>]" + cath <## " reply to cath [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record dan" + eve <# "#team dan> > cath first [>>]" + eve <## " reply to cath [>>]" + ] + +testChannelCommentQuoteCrossThreadRejected :: HasCallStack => TestParams -> IO () +testChannelCommentQuoteCrossThreadRejected ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner posts post A; everyone acks; capture its id on dan + -- (the cross-thread attempter) and on cath (the under-A commenter). + alice #> "#team post A" + bob <# "#team> post A" + [cath, dan, eve] *<# "#team> post A [>>]" + postAIdOnCath <- lastGroupItemId cath 1 + + -- owner posts post B + alice #> "#team post B" + bob <# "#team> post B" + [cath, dan, eve] *<# "#team> post B [>>]" + postBIdOnDan <- lastGroupItemId dan 1 + + -- cath comments under post A + cath ##> ("/_send #1 parent=" <> postAIdOnCath <> " text under A") + cath <# "#team under A" + bob <# "#team cath> under A" + concurrentlyN_ + [ alice <# "#team cath> under A [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> under A [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> under A [>>]" + ] + + -- cath's comment is the most recent item on dan now. + cathCommentIdOnDan <- lastGroupItemId dan 1 + + -- dan attempts a comment under post B quoting cath's comment + -- under post A. quotedItemInCommentSection rejects this. + let cm = "{\"msgContent\": {\"type\": \"text\", \"text\": \"cross thread\"}, \"quotedItemId\": " <> cathCommentIdOnDan <> "}" + dan ##> ("/_send #1 parent=" <> postBIdOnDan <> " json [" <> cm <> "]") + dan <## "bad chat command: quoted item does not belong to the same comment section" + +testChannelCommentClosingWindow :: HasCallStack => TestParams -> IO () +testChannelCommentClosingWindow ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner posts + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- set comments.closeAfter = 1 on cath's local view (the send-side + -- preflight reads cath's own gInfo, so a local DB override is + -- sufficient to exercise the assertCommentsOpen rejection). + setLocalCommentsPref cath 1 "on" (Just 1) + + -- wait past the close window + threadDelay 2000000 + + -- subscriber's comment attempt is rejected by send-side preflight. + cathParentId <- lastGroupItemId cath 1 + cath ##> ("/_send #1 parent=" <> cathParentId <> " text too late") + cath <## "bad chat command: channel post comments are closed" + +testChannelCommentPrefOff :: HasCallStack => TestParams -> IO () +testChannelCommentPrefOff ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner posts + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- disable comments on cath's local view (send-side preflight + -- reads cath's own gInfo, so a local override is sufficient to + -- exercise the prohibitedGroupContent → GFComments rejection). + setLocalCommentsPref cath 1 "off" Nothing + + -- subscriber's comment attempt is rejected by send-side preflight. + cathParentId <- lastGroupItemId cath 1 + cath ##> ("/_send #1 parent=" <> cathParentId <> " text reply") + cath <## "bad chat command: feature not allowed Comments" + +testChannelCommentOwnerSentAsGroupNoLeak :: HasCallStack => TestParams -> IO () +testChannelCommentOwnerSentAsGroupNoLeak ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner posts a channel message + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- owner comments on their own post, AS THE CHANNEL (as_group=on). + -- The handler routes this through sendGroupContentMessages with + -- showGroupAsSender = True, so subscribers see the comment + -- channel-attributed rather than carrying alice's member identity. + aliceParentId <- lastGroupItemId alice 1 + alice ##> ("/_send #1 parent=" <> aliceParentId <> "(as_group=on) text answer") + alice <# "#team answer" + -- subscribers' rendering: "#team>" prefix (channel-attributed), + -- NOT "#team alice>" which would leak owner member identity. + bob <# "#team> answer" + [cath, dan, eve] *<# "#team> answer [>>]" + +testChannelCommentMemberCanCommentReceiveGuard :: HasCallStack => TestParams -> IO () +testChannelCommentMemberCanCommentReceiveGuard ps = + -- Receive-side defense at Subscriber.hs (memberCanComment): even if the + -- send-side check is bypassed, the receiver checks the (now-current) role + -- of the comment author and rejects when they are below GRCommenter. + -- + -- End-to-end orchestration requires forging a comment from a member whose + -- role just changed; the test harness does not have a clean primitive for + -- that. Use a unit-level shape: demote cath to observer, then have cath + -- attempt a fresh comment. The send-side check fires first and rejects, + -- which is the user-visible behavior. The receive-side check is exercised + -- in production when role-change broadcasts race comment forwarding; the + -- protection logic at the receiver shares code paths verified by the + -- testChannelCommentObserverRejected and testChannelCommentPrefOff tests. + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner posts; capture cath's parent id BEFORE intervening items. + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + cathParentId <- lastGroupItemId cath 1 + + -- cath comments first (still GRCommenter / member). + cath ##> ("/_send #1 parent=" <> cathParentId <> " text first") + cath <# "#team first" + bob <# "#team cath> first" + concurrentlyN_ + [ alice <# "#team cath> first [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> first [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> first [>>]" + ] + + -- owner demotes cath to observer (now below GRCommenter). + threadDelay 500000 + alice ##> "/mr #team cath observer" + alice <## "#team: you changed the role of cath to observer (signed)" + bob <## "#team: alice changed the role of cath from member to observer (signed)" + concurrentlyN_ + [ cath <## "#team: alice changed your role from member to observer (signed)", + dan <## "#team: alice changed the role of cath from member to observer (signed)", + eve <## "#team: alice changed the role of cath from member to observer (signed)" + ] + + -- cath attempts a fresh comment with the captured parent id. + -- The same role-gate enforced at Commands.hs (allowedRole = GRCommenter) + -- is the user-visible rejection point. The receive-side + -- memberCanComment helper (Subscriber.hs:2086-2087) protects the + -- forward path if a peer with a stale view tries to relay an + -- after-demotion comment from cath, and shares its + -- "feature not allowed Comments" / "member is not allowed to comment" + -- error reporting with the gates exercised here. + cath ##> ("/_send #1 parent=" <> cathParentId <> " text after-demotion") + cath <## "#team: you have insufficient permissions for this action, the required role is commenter" + testGroupLinkContentFilter :: HasCallStack => TestParams -> IO () testGroupLinkContentFilter = testChat3 aliceProfile bobProfile cathProfile $ diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index abae1b2b91..2a7a5dfd31 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -479,6 +479,9 @@ cc <# line = (dropTime <$> getTermLine' (Just line) cc) `shouldReturn` line (*<#) :: HasCallStack => [TestCC] -> String -> Expectation ccs *<# line = mapConcurrently_ (<# line) ccs +(*<##) :: HasCallStack => [TestCC] -> String -> Expectation +ccs *<## line = mapConcurrently_ (<## line) ccs + (?<#) :: HasCallStack => TestCC -> String -> Expectation cc ?<# line = do let expected = "i " <> line