From ed703b04b06c7bac074dfd28991c30835582d6a7 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Thu, 9 Apr 2026 13:46:40 +0400 Subject: [PATCH] wip --- src/Simplex/Chat.hs | 2 +- src/Simplex/Chat/Controller.hs | 2 + src/Simplex/Chat/Library/Commands.hs | 99 ++++++-- src/Simplex/Chat/Library/Internal.hs | 105 ++++---- src/Simplex/Chat/Library/Subscriber.hs | 106 +++++--- src/Simplex/Chat/Messages.hs | 23 +- src/Simplex/Chat/Protocol.hs | 78 +++--- src/Simplex/Chat/Store/Groups.hs | 18 ++ src/Simplex/Chat/Store/Messages.hs | 332 ++++++++++++++++++------- tests/ChatTests/Groups.hs | 262 +++++++++++++++++++ tests/ChatTests/Utils.hs | 19 ++ tests/ProtocolTests.hs | 57 ++--- 12 files changed, 841 insertions(+), 262 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 2671774603..7f85413fb4 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -114,7 +114,7 @@ defaultChatConfig = highlyAvailable = False, deliveryWorkerDelay = 0, deliveryBucketSize = 10000, - channelSubscriberRole = GRObserver, + channelSubscriberRole = GRCommenter, deviceNameForRemote = "", remoteCompression = True, chatHooks = defaultChatHooks diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 16652f90dd..4793f4c67e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -324,6 +324,8 @@ data ChatCommand | APIGetChatItems {chatPagination :: ChatPagination, search :: Maybe Text} | APIGetChatItemInfo {chatRef :: ChatRef, chatItemId :: ChatItemId} | APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage} + | APISendComment {groupId :: GroupId, parentChatItemId :: ChatItemId, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage} + | APISetCommentsDisabled {groupId :: GroupId, parentChatItemId :: ChatItemId, disabled :: Bool} | APICreateChatTag ChatTagData | APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId)) | APIDeleteChatTag ChatTagId diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index d14642befc..f1c0526a09 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -563,7 +563,7 @@ processChatCommand vr nm = \case (directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId contentFilter pagination search) pure $ CRApiChat user (AChat SCTDirect directChat) navInfo CTGroup -> do - (groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId scope_ contentFilter pagination search) + (groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId scope_ Nothing contentFilter pagination search) groupChat' <- checkSupportChatAttention user groupChat pure $ CRApiChat user (AChat SCTGroup groupChat') navInfo CTLocal -> do @@ -627,6 +627,31 @@ processChatCommand vr nm = \case g <- getGroupInfo db vr user chatId (g,) <$> mapM (composedMessageReqMentions db user g) cms sendGroupContentMessages user gInfo gsScope asGroup live itemTTL cmrs + APISendComment groupId parentItemId live itemTTL cms -> withUser $ \user -> do + mapM_ assertAllowedContent' cms + withGroupLock "sendComment" groupId $ do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + unless (useRelays' gInfo) $ throwCmdError "comments are only supported in channel groups" + (channelMsgInfo, cmrs) <- withFastStore $ \db -> do + cmi <- getChannelMsgInfo db user groupId parentItemId + cmrs' <- mapM (composedMessageReqMentions db user gInfo) cms + pure (cmi, cmrs') + assertMultiSendable live cmrs + recipients <- getGroupRecipients vr user gInfo Nothing groupKnockingVersion + sendGroupContentMessages_ user gInfo Nothing False Nothing (Just channelMsgInfo) recipients live itemTTL cmrs + APISetCommentsDisabled groupId parentItemId disabled -> withUser $ \user -> + withGroupLock "setCommentsDisabled" groupId $ do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + unless (useRelays' gInfo) $ throwCmdError "comments are only supported in channel groups" + channelMsgInfo <- withFastStore $ \db -> getChannelMsgInfo db user groupId parentItemId + let GroupInfo {membership = GroupMember {memberRole = userRole}} = gInfo + when (userRole < GRModerator) $ throwCmdError "user is not allowed to disable comments" + withFastStore' $ \db -> setChannelMsgCommentsDisabled db parentItemId disabled + let ChannelMsgInfo {channelMsgSharedId} = channelMsgInfo + chatMsgEvent = XMsgPrefs {msgId = channelMsgSharedId, comments = MsgCommentsPref {disabled}} + recipients <- getGroupRecipients vr user gInfo Nothing groupKnockingVersion + void $ sendGroupMessages user gInfo Nothing False recipients (chatMsgEvent :| []) + ok user APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do _ <- createChatTag db user emoji text CRChatTags user <$> getUserChatTags db user @@ -1281,7 +1306,7 @@ processChatCommand vr nm = \case Just smId -> void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing Nothing -> do - (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing + (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] APIRejectContact connReqId -> withUser $ \user -> do @@ -2026,7 +2051,7 @@ processChatCommand vr nm = \case -- create changed feature items (connecting incognito sends default preferences, instead of user preferences) lift . when incognito $ createContactChangedFeatureItems user ct ct' forM_ msgContent_ $ \mc -> do - let evt = XMsgNew $ MCSimple (extMsgContent mc Nothing) + let evt = XMsgNew $ mcSimple mc (msg, _) <- sendDirectContactMessage user ct' evt ci <- saveSndChatItem user (CDDirectSnd ct') msg (CISndMsgContent mc) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct') ci] @@ -2374,7 +2399,7 @@ processChatCommand vr nm = \case Right conn | directOrUsed ct -> (ct, conn) : ctConns _ -> ctConns ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json) - ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ MCSimple (extMsgContent mc Nothing)) + ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ mcSimple mc) ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, (vrValue msgBody, [msgId])) combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage) @@ -2383,7 +2408,7 @@ processChatCommand vr nm = \case combineResults _ _ (Left e) = Left e createCI :: DB.Connection -> User -> Bool -> UTCTime -> (Contact, SndMessage) -> IO () createCI db user hasLink createdAt (ct, sndMsg) = - void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt + void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing Nothing False hasLink createdAt SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do contactId <- withFastStore $ \db -> getContactIdByName db user cName quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg @@ -2445,7 +2470,16 @@ processChatCommand vr nm = \case -- generate owner key, OwnerAuth signed by root key memberId <- MemberId <$> liftIO (encodedRandomBytes gVar 12) (memberPrivKey, ownerAuth) <- liftIO $ SL.newOwnerAuth gVar (unMemberId memberId) rootPrivKey - let groupProfile' = (groupProfile :: GroupProfile) {publicGroup = Just PublicGroupProfile {groupType = GTChannel, groupLink = sLnk, publicGroupId = B64UrlByteString entityId}} + let GroupProfile {groupPreferences = basePrefs_} = groupProfile + basePrefs = fromMaybe emptyGroupPrefs basePrefs_ + GroupPreferences {comments = commentsPref_} = basePrefs + commentsPref = fromMaybe (CommentsGroupPreference {enable = FEOn, closeAfter = Nothing}) commentsPref_ + channelPrefs = (basePrefs :: GroupPreferences) {comments = Just commentsPref} + groupProfile' = + (groupProfile :: GroupProfile) + { publicGroup = Just PublicGroupProfile {groupType = GTChannel, groupLink = sLnk, publicGroupId = B64UrlByteString entityId}, + groupPreferences = Just channelPrefs + } userData = encodeShortLinkData $ GroupShortLinkData {groupProfile = groupProfile', publicGroupData = Just (PublicGroupData 1)} userLinkData = UserContactLinkData UserContactData {direct = False, owners = [ownerAuth], relays = [], userData} -- create connection with prepared link (single network call) @@ -2570,7 +2604,7 @@ processChatCommand vr nm = \case void $ sendGroupMessage user gInfo scope ([m] <> rcpModMs') msg when (maxVersion (memberChatVRange m) < groupKnockingVersion) $ forM_ (memberConn m) $ \mConn -> do - let msg2 = XMsgNew $ MCSimple $ extMsgContent (MCText acceptedToGroupMessage) Nothing + let msg2 = XMsgNew $ mcSimple (MCText acceptedToGroupMessage) void $ sendDirectMemberMessage mConn msg2 groupId when (memberCategory m == GCInviteeMember) $ do introduceToRemaining vr user gInfo m {memberRole = role} @@ -2658,7 +2692,7 @@ processChatCommand vr nm = \case (msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients events let signed = any (either (const False) (isJust . signedMsg_)) msgs_ itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing Nothing False when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch" (errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange) let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_ @@ -2706,7 +2740,7 @@ processChatCommand vr nm = \case (msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events let msgSigned = any (either (const False) (isJust . signedMsg_)) msgs_ itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing 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 @@ -2795,7 +2829,7 @@ processChatCommand vr nm = \case Right (Just a) -> Just $ Right a Left e -> Just $ Left e itemsData = mapMaybe skipUnwantedItem itemsData_ - cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) False itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) False itemsData Nothing Nothing False deleteMembersConnections' user memsToDelete True (errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete) let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo chatScopeInfo)) $ rights cis_ @@ -4116,7 +4150,7 @@ processChatCommand vr nm = \case msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_ when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch" - r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) False itemsData timed_ live + r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) False itemsData Nothing timed_ live processSendErrs r forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> forM_ cis $ \ci -> @@ -4134,9 +4168,10 @@ processChatCommand vr nm = \case prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect))) prepareMsgs cmsFileInvs timed_ = withFastStore $ \db -> forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, _), fInv_) -> do + let base = (mcSimple mc) {file = fInv_, ttl = ttl' <$> timed_, live = justTrue live} case (quotedItemId, itemForwarded) of - (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing) - (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing) + (Nothing, Nothing) -> pure (base, Nothing) + (Nothing, Just _) -> pure (base {forward = Just True}, Nothing) (Just qiId, Nothing) -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- getDirectChatItem db user contactId qiId @@ -4144,7 +4179,7 @@ processChatCommand vr nm = \case let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} qmc = quoteContent mc origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Just quotedItem) + pure (base {quote = Just QuotedMsg {msgRef, content = qmc}}, Just quotedItem) (Just _, Just _) -> throwError SEInvalidQuote where quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool) @@ -4157,23 +4192,26 @@ processChatCommand vr nm = \case assertMultiSendable live cmrs chatScopeInfo <- mapM (getChatScopeInfo vr user) scope recipients <- getGroupRecipients vr user gInfo chatScopeInfo modsCompatVersion - sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs + sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo Nothing recipients live itemTTL cmrs where hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion - sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse - sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs = do + sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> Maybe ChannelMsgInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse + sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo channelMsgInfo_ recipients live itemTTL cmrs = do forM_ allowedRole $ assertUserGroupRole gInfo assertGroupContentAllowed + assertCommentsOpen processComposedMessages where allowedRole :: Maybe GroupMemberRole - allowedRole = case scope of - Nothing -> Just GRAuthor - Just (GCSMemberSupport Nothing) + allowedRole = case (scope, channelMsgInfo_) of + (Nothing, Nothing) -> Just GRAuthor + (Just (GCSMemberSupport Nothing), Nothing) | memberPending membership -> Nothing | otherwise -> Just GRObserver - Just (GCSMemberSupport (Just _gmId)) -> Just GRModerator + (Just (GCSMemberSupport (Just _gmId)), Nothing) -> Just GRModerator + (Nothing, Just _) -> Just GRCommenter + _ -> Nothing assertGroupContentAllowed :: CM () assertGroupContentAllowed = case findProhibited (L.toList cmrs) of @@ -4183,8 +4221,19 @@ processChatCommand vr nm = \case findProhibited :: [ComposedMessageReq] -> Maybe GroupFeature findProhibited = foldr' - (\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft), _) acc -> prohibitedGroupContent gInfo membership chatScopeInfo mc ft fileSource True <|> acc) + (\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft), _) acc -> prohibitedGroupContent gInfo membership chatScopeInfo channelMsgInfo_ mc ft fileSource True <|> acc) Nothing + assertCommentsOpen :: CM () + assertCommentsOpen = case channelMsgInfo_ of + Just _ -> do + now <- liftIO getCurrentTime + when (commentsClosed gInfo channelMsgInfo_ now) $ + throwCmdError "channel post comments are closed" + Nothing -> pure () + parentChatItemId_ :: Maybe ChatItemId + parentChatItemId_ = (\ChannelMsgInfo {channelMsgItem} -> cChatItemId channelMsgItem) <$> channelMsgInfo_ + parentRef_ :: Maybe MsgRef + parentRef_ = channelMsgRef <$> channelMsgInfo_ processComposedMessages :: CM ChatResponse processComposedMessages = do -- TODO [relays] single description for all recipients @@ -4193,7 +4242,7 @@ processChatCommand vr nm = \case (chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ (msgs_, gsr) <- sendGroupMessages user gInfo Nothing showGroupAsSender recipients chatMsgEvents let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData timed_ live + cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData parentChatItemId_ timed_ live when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch" createMemberSndStatuses cis_ msgs_ gsr let r@(_, cis) = partitionEithers cis_ @@ -4216,7 +4265,7 @@ processChatCommand vr nm = \case forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, ciMentions), fInv_) -> let msgScope = toMsgScope gInfo <$> chatScopeInfo mentions = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions - in prepareGroupMsg db user gInfo msgScope showGroupAsSender mc mentions quotedItemId itemForwarded fInv_ timed_ live + in prepareGroupMsg db user gInfo msgScope parentRef_ showGroupAsSender mc mentions quotedItemId itemForwarded fInv_ timed_ live createMemberSndStatuses :: [Either ChatError (ChatItem 'CTGroup 'MDSnd)] -> NonEmpty (Either ChatError SndMessage) -> @@ -4754,6 +4803,8 @@ chatCommandP = "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> textP)), "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal), "/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), + "/_comment #" *> (APISendComment <$> A.decimal <* A.space <*> A.decimal <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), + "/_comments_disabled #" *> (APISetCommentsDisabled <$> A.decimal <* A.space <*> A.decimal <* A.space <*> onOffP), "/_create tag " *> (APICreateChatTag <$> jsonP), "/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP), "/_delete tag " *> (APIDeleteChatTag <$> A.decimal), diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index f91ee19bce..4f199f48ac 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -201,25 +201,23 @@ toggleNtf m ntfOn = forM_ (memberConnId m) $ \connId -> withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchAllErrors` eToView -prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)) -prepareGroupMsg db user g@GroupInfo {membership} msgScope showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of - (Nothing, Nothing) -> - let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender) - in pure (XMsgNew mc', Nothing) - (Nothing, Just _) -> - let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender) - in pure (XMsgNew mc', Nothing) - (Just quotedItemId, Nothing) -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <- - getGroupCIWithReactions db user g quotedItemId - (origQmc, qd, sent, member_) <- quoteData qci membership - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = memberId' <$> member_} - qmc = quoteContent mc origQmc file - (qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions - quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'} - mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender)) - pure (XMsgNew mc', Just quotedItem) - (Just _, Just _) -> throwError SEInvalidQuote +prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> Maybe MsgRef -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)) +prepareGroupMsg db user g@GroupInfo {membership} msgScope parentRef_ showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = do + let base = (mcSimple mc) {mentions, file = fInv_, ttl = ttl' <$> timed_, live = justTrue live, scope = msgScope, asGroup = justTrue showGroupAsSender, parent = parentRef_} + case (quotedItemId_, itemForwarded) of + (Nothing, Nothing) -> pure (XMsgNew base, Nothing) + (Nothing, Just _) -> pure (XMsgNew base {forward = Just True}, Nothing) + (Just quotedItemId, Nothing) -> do + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <- + getGroupCIWithReactions db user g quotedItemId + (origQmc, qd, sent, member_) <- quoteData qci membership + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = memberId' <$> member_} + qmc = quoteContent mc origQmc file + (qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions + quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'} + mc' = base {quote = Just QuotedMsg {msgRef, content = qmc'}} + pure (XMsgNew mc', Just quotedItem) + (Just _, Just _) -> throwError SEInvalidQuote where quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, Maybe GroupMember) quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote @@ -338,13 +336,20 @@ quoteContent mc qmc ciFile_ qFileName = maybe qText (T.pack . getFileName) ciFile_ qTextOrFile = if T.null qText then qFileName else qText -prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature -prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole = userRole}} m scopeInfo mc ft file_ sent +prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> Maybe ChannelMsgInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature +prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole = userRole}} m scopeInfo channelMsgInfo mc ft file_ sent | isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) && not hostApprovalVoice = Just GFVoice | isNothing scopeInfo && not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles | isNothing scopeInfo && isReport mc && (badReportUser || not (groupFeatureAllowed SGFReports gInfo)) = Just GFReports | isNothing scopeInfo && prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks - | otherwise = Nothing + | otherwise = case channelMsgInfo of + Just ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {meta = CIMeta {itemDeleted, commentsDisabled}}} + | not (useRelays' gInfo) -> Just GFComments + | not (groupFeatureAllowed SGFComments gInfo) -> Just GFComments + | isJust itemDeleted -> Just GFComments + | commentsDisabled -> Just GFComments + | otherwise -> Nothing + Nothing -> Nothing where hostApprovalVoice | sent = userRole >= GRAdmin && sendApprovalPhase @@ -360,6 +365,19 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole | sent = userRole >= GRModerator | otherwise = userRole < GRModerator +-- True iff the channel post's commenting window has expired. +-- The group preference `comments.closeAfter` is the duration in seconds +-- since post creation; `Nothing` means the window never closes. +commentsClosed :: GroupInfo -> Maybe ChannelMsgInfo -> UTCTime -> Bool +commentsClosed + GroupInfo {fullGroupPreferences = FullGroupPreferences {comments = CommentsGroupPreference {closeAfter}}} + (Just ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {meta = CIMeta {itemTs}}}) + now = + case closeAfter of + Just secs -> diffUTCTime now itemTs > fromIntegral secs + Nothing -> False +commentsClosed _ Nothing _ = False + prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool prohibitedSimplexLinks gInfo m ft = not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) @@ -1062,7 +1080,7 @@ introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRol let msg = if maxVersion (memberChatVRange m) >= groupKnockingVersion then XGrpLinkAcpt GAPendingReview memberRole memberId - else XMsgNew $ MCSimple $ extMsgContent (MCText pendingReviewMessage) Nothing + else XMsgNew $ mcSimple (MCText pendingReviewMessage) void $ sendDirectMemberMessage mConn msg groupId modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo let rcpModMs = filter shouldIntroduceToMod modMs @@ -1197,7 +1215,7 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c descrEvent_ | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do let GroupInfo {groupProfile = GroupProfile {description}} = gInfo - fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description + fmap (\descr -> XMsgNew $ mcSimple (MCText descr)) description | otherwise = Nothing itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] itemForwardEvents cci = case cci of @@ -1254,7 +1272,7 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' asGroup = isNothing sender_ -- TODO [knocking] send history to other scopes too? - (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing asGroup mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False + (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing Nothing asGroup mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False -- for channel messages default chat version range to membership range let senderVRange = maybe (memberChatVRange' membership) memberChatVRange' sender_ xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} @@ -2286,7 +2304,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do let itemTexts = ciContentTexts content - saveSndChatItems user cd False [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case + saveSndChatItems user cd False [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] Nothing itemTimed live >>= \case [Right ci] -> pure ci _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" @@ -2307,10 +2325,11 @@ saveSndChatItems :: ChatDirection c 'MDSnd -> ShowGroupAsSender -> [Either ChatError (NewSndChatItemData c)] -> + Maybe ChatItemId -> Maybe CITimed -> Bool -> CM [Either ChatError (ChatItem c 'MDSnd)] -saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do +saveSndChatItems user cd showGroupAsSender itemsData parentChatItemId_ itemTimed live = do createdAt <- liftIO getCurrentTime vr <- chatVersionRange when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ @@ -2320,9 +2339,9 @@ saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId, signedMsg_}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do let hasLink_ = ciContentHasLink content (snd itemTexts) - ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt + ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded parentChatItemId_ itemTimed live hasLink_ createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing (MSSVerified <$ signedMsg_) createdAt + let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded parentChatItemId_ itemTimed live False hasLink_ createdAt Nothing (MSSVerified <$ signedMsg_) createdAt Right <$> case cd of CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions _ -> pure ci @@ -2332,13 +2351,13 @@ saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg broker saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv, ChatInfo c) saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = - saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty + saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing Nothing False M.empty ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) ciContentNoParse content = (content, (ciContentToText content, Nothing)) -saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c) -saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do +saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c) +saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile parentChatItemId_ itemTimed live mentions = do createdAt <- liftIO getCurrentTime vr <- chatVersionRange withStore' $ \db -> do @@ -2351,9 +2370,9 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem else pure $ toChatInfo cd let showAsGroup = case cd of CDChannelRcv {} -> True; _ -> False hasLink_ = ciContentHasLink content ft_ - (ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention hasLink_ brokerTs createdAt + (ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content parentChatItemId_ itemTimed live userMention hasLink_ brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt + let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded parentChatItemId_ itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt ci' <- case toChatInfo cd of GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions' _ -> pure ci @@ -2377,16 +2396,16 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem _ -> Nothing -- TODO [mentions] optimize by avoiding unnecessary parsing -mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d -mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs = +mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d +mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded parentChatItemId_ itemTimed live userMention itemTs forwardedByMember currentTs = let ts@(_, ft_) = ciContentTexts content hasLink_ = ciContentHasLink content ft_ - in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember Nothing currentTs + in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded parentChatItemId_ itemTimed live userMention hasLink_ itemTs forwardedByMember Nothing currentTs -mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d -mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs = +mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d +mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded parentChatItemId_ itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs = let itemStatus = ciCreateStatus content - meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned currentTs currentTs + meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned parentChatItemId_ 0 False currentTs currentTs in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file} ciContentHasLink :: CIContent d -> Maybe MarkdownList -> Bool @@ -2661,7 +2680,7 @@ createChatItems user itemTs_ dirsCIContents = do createACI (content, sharedMsgId) = do let hasLink_ = ciContentHasLink content Nothing ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ itemTs createdAt - let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt + let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci -- rcvMem_ Nothing means message from channel - treated same as message from moderator, @@ -2694,9 +2713,9 @@ createLocalChatItems user cd itemsData createdAt = do createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd) createItem db (content, ciFile, itemForwarded, ts@(_, ft_)) = do let hasLink_ = ciContentHasLink content ft_ - ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt + ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing Nothing False False hasLink_ createdAt Nothing Nothing createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt + pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing Nothing False False hasLink_ createdAt Nothing Nothing createdAt withUser' :: (User -> CM ChatResponse) -> CM ChatResponse withUser' action = diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index a8e9bcfdf5..afc7b88cc5 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -697,7 +697,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Just UserContactRequest {welcomeSharedMsgId = Just smId} -> void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing _ -> do - (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing + (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] @@ -979,7 +979,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = checkSendAsGroup asGroup $ memberCanSend (Just m'') scope $ newGroupContentMessage gInfo' (Just m'') mc msg brokerTs False where - ExtMsgContent {scope, asGroup} = mcExtMsgContent mc + MsgContainer {scope, asGroup} = mc -- file description is always allowed, to allow sending files to support scope XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> @@ -1009,6 +1009,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' msg + XMsgPrefs {msgId = parentSharedMsgId, comments} -> fmap ctx <$> xMsgPrefs gInfo' (Just m'') parentSharedMsgId comments -- TODO [knocking] why don't we forward these messages? XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward gInfo' Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs @@ -1203,7 +1204,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Just UserContactRequest {welcomeSharedMsgId = Just smId} -> void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing _ -> do - msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ MCSimple $ extMsgContent mc Nothing + msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ mcSimple mc ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc) withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing) ci] @@ -1519,7 +1520,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = memberCanSend (Just m@GroupMember {memberRole}) msgScope a = case msgScope of Just MSMember {} -> a Nothing - | memberRole > GRObserver || memberPending m -> a + | memberRole >= GRAuthor || memberPending m -> a | otherwise -> messageError "member is not allowed to send messages" $> Nothing processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () @@ -1712,7 +1713,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do - let ExtMsgContent content _ fInv_ _ _ _ _ = mcExtMsgContent mc + let MsgContainer {content, file = fInv_, ttl = itemTTL, live = live_} = mc -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete -- case content of -- MCText "hello 111" -> @@ -1723,8 +1724,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = then do void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False else do - let ExtMsgContent _ _ _ itemTTL live_ _ _ = mcExtMsgContent mc - timed_ = rcvContactCITimed ct itemTTL + let timed_ = rcvContactCITimed ct itemTTL live = fromMaybe False live_ file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live @@ -1732,7 +1732,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where brokerTs = metaBrokerTs msgMeta newChatItem content ciFile_ timed_ live = do - (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty + (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ Nothing timed_ live M.empty reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci {reactions}] @@ -1812,7 +1812,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvContactCITimed ct ttl ts = ciContentTexts content - (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty + (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live M.empty ci' <- withStore' $ \db -> do createChatItemVersion db (chatItemId' ci) brokerTs mc updateDirectChatItem' db user contactId ci content True live Nothing Nothing @@ -1943,40 +1943,56 @@ 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 -> do - createContentItem gInfo Nothing Nothing + createContentItem gInfo Nothing Nothing Nothing -- no delivery task - message already forwarded by relay pure Nothing Just m@GroupMember {memberId} -> do (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_ + channelMsgInfo_ <- resolveCommentParent gInfo' parent_ if blockedByAdmin m' then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing - else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of + else case prohibitedGroupContent gInfo' m' scopeInfo channelMsgInfo_ content ft_ fInv_ False of Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing - Nothing -> - withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case - Just ciModeration -> do - applyModeration gInfo' m' scopeInfo ciModeration - withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_ - pure Nothing - Nothing -> do - createContentItem gInfo' (Just m') scopeInfo - pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup + Nothing -> do + now <- liftIO getCurrentTime + if commentsClosed gInfo' channelMsgInfo_ now + then messageError "channel post comments are closed" $> Nothing + else + withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case + Just ciModeration -> do + applyModeration gInfo' m' scopeInfo ciModeration + withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_ + pure Nothing + Nothing -> do + createContentItem gInfo' (Just m') scopeInfo channelMsgInfo_ + pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup where - rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False + rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo Nothing (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL live' = fromMaybe False live_ - ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ asGroup_ = mcExtMsgContent mc + MsgContainer {content, mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_, parent = parent_} = mc sentAsGroup = asGroup_ == Just True ts@(_, ft_) = msgContentTexts content + -- Resolve the parent post (if any) referenced by this message's container. + -- Returns Nothing for plain main-channel messages, throws messageError on + -- malformed or unknown parent references so the message is dropped. + resolveCommentParent :: GroupInfo -> Maybe MsgRef -> CM (Maybe ChannelMsgInfo) + resolveCommentParent _ Nothing = pure Nothing + resolveCommentParent _ (Just MsgRef {msgId = Nothing}) = + messageError "channel comment parent missing shared msg id" $> Nothing + resolveCommentParent gInfo' (Just MsgRef {msgId = Just parentSharedId}) = + (Just <$> withStore (\db -> getChannelMsgInfoBySharedMsgId db user gInfo' parentSharedId)) + `catchAllErrors` \_ -> messageError "channel comment parent not found" $> Nothing -- m' is Maybe GroupMember - saveRcvCI gInfo' m' scopeInfo = + saveRcvCI gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile = let itemMember_ = if sentAsGroup then Nothing else m' chatDir = maybe (CDChannelRcv gInfo' scopeInfo) (CDGroupRcv gInfo' scopeInfo) itemMember_ - in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs + parentItemId_ = (\ChannelMsgInfo {channelMsgItem} -> cChatItemId channelMsgItem) <$> channelMsgInfo'_ + in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs ciContent ciFile parentItemId_ createBlockedByAdmin gInfo' m' scopeInfo | groupFeatureAllowed SGFFullDelete gInfo' = do -- ignores member role when blocked by admin - (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty + (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo Nothing (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo' ci brokerTs groupMsgToView cInfo ci' | otherwise = do @@ -1986,9 +2002,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = groupMsgToView cInfo ci' applyModeration gInfo' m'@GroupMember {memberRole} scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} | moderatorRole < GRModerator || moderatorRole < memberRole = - createContentItem gInfo' (Just m') scopeInfo + createContentItem gInfo' (Just m') scopeInfo Nothing | groupFeatureMemberAllowed SGFFullDelete moderator gInfo' = do - (ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty + (ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo Nothing (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo' ci moderator moderatedAt groupMsgToView cInfo ci' | otherwise = do @@ -1998,17 +2014,17 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CEvtChatItemsDeleted user deletions False False -- m' is Maybe GroupMember createNonLive gInfo' m' scopeInfo file_ = do - saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions - createContentItem gInfo' m' scopeInfo = do + saveRcvCI gInfo' m' scopeInfo Nothing (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions + createContentItem gInfo' m' scopeInfo channelMsgInfo'_ = do file_ <- processFileInv gInfo' m' - newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live' + newChatItem gInfo' m' scopeInfo channelMsgInfo'_ (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live' unless (maybe False memberBlocked m') $ autoAcceptFile file_ processFileInv gInfo' m' = let fileMember_ = if sentAsGroup then Nothing else m' in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ - newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do + newChatItem gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile_ timed live = do let mentions' = if maybe False memberBlocked m' then [] else mentions - (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions' + (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile_ timed live mentions' ci' <- maybe (pure ci) (\m -> blockedMemberCI gInfo' m ci) m' let memberId_ = memberId' <$> m' reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId_ sharedMsgId) sharedMsgId_ @@ -2037,7 +2053,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_ pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo) Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing) - (ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions' + (ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live mentions' ci' <- withStore' $ \db -> do createChatItemVersion db (chatItemId' ci) brokerTs mc updateGroupChatItem db user groupId ci content True live Nothing @@ -2191,7 +2207,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" - (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty + (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing Nothing False M.empty toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci] where brokerTs = metaBrokerTs msgMeta @@ -2205,7 +2221,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" - (ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty + (ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing Nothing False M.empty ci' <- blockedMemberCI gInfo m ci groupMsgToView cInfo ci' @@ -2680,7 +2696,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0) featureRejected f = do let content = ciContentNoParse $ CIRcvChatFeatureRejected f - (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty + (ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing Nothing False M.empty toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci] -- to party initiating call @@ -3147,6 +3163,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing | otherwise = updateGroupPrefs_ msgSigned g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} + xMsgPrefs :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgCommentsPref -> CM (Maybe DeliveryJobScope) + xMsgPrefs g author_ parentSharedMsgId MsgCommentsPref {disabled} + | not (useRelays' g) = messageError "x.msg.prefs not allowed in p2p groups" $> Nothing + | maybe False (\GroupMember {memberRole} -> memberRole < GRModerator) author_ = + messageError "x.msg.prefs with insufficient member permissions" $> Nothing + | otherwise = do + parent_ <- + (Just <$> withStore (\db -> getGroupChatItemBySharedMsgId db user g Nothing parentSharedMsgId)) + `catchAllErrors` \_ -> messageError "x.msg.prefs: parent chat item not found" $> Nothing + case parent_ of + Just parentCI -> do + withStore' $ \db -> setChannelMsgCommentsDisabled db (cChatItemId parentCI) disabled + pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} + Nothing -> pure Nothing + updateGroupPrefs_ :: Maybe MsgSigStatus -> GroupInfo -> GroupMember -> GroupPreferences -> CM () updateGroupPrefs_ msgSigned g@GroupInfo {groupProfile = p} m ps' = unless (groupPreferences p == Just ps') $ do @@ -3268,7 +3299,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XMsgNew mc -> void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True where - ExtMsgContent {scope} = mcExtMsgContent mc + MsgContainer {scope} = mc -- file description is always allowed, to allow sending files to support scope XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> @@ -3285,6 +3316,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' rcvMsg + XMsgPrefs {msgId = parentSharedMsgId, comments} -> void $ xMsgPrefs gInfo author_ parentSharedMsgId comments _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) where withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM () diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index b010040edf..2d10498a06 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -342,6 +342,27 @@ data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (Cha deriving instance Show (CChatItem c) +-- | Resolved parent post for a channel comments thread. +-- Threaded through the send/receive paths so the wire-side MsgRef and +-- the DB-side parent_chat_item_id are derived from a single resolution. +data ChannelMsgInfo = ChannelMsgInfo + { channelMsgItem :: CChatItem 'CTGroup, + channelMsgSharedId :: SharedMsgId + } + deriving (Show) + +-- Build a MsgRef pointing at a channel post for the wire-side `parent` field +-- of a comment message. Channel posts have no member identity, so memberId +-- is Nothing for both subscriber-received (CIChannelRcv) and owner-sent +-- (CIGroupSnd with showGroupAsSender = True) cases. +channelMsgRef :: ChannelMsgInfo -> MsgRef +channelMsgRef ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {chatDir, meta = CIMeta {itemTs}}, channelMsgSharedId} = + MsgRef {msgId = Just channelMsgSharedId, sentAt = itemTs, sent = isSnd, memberId = Nothing} + where + isSnd = case chatDir of + CIGroupSnd -> True + _ -> False + cChatItemId :: CChatItem c -> ChatItemId cChatItemId (CChatItem _ ci) = chatItemId' ci @@ -1324,7 +1345,7 @@ data CIForwardedFrom cmForwardedFrom :: AChatMsgEvent -> Maybe CIForwardedFrom cmForwardedFrom = \case - ACME _ (XMsgNew (MCForward _)) -> Just CIFFUnknown + ACME _ (XMsgNew mc) | isMCForward mc -> Just CIFFUnknown _ -> Nothing data CIForwardedFromTag diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 6599ddc80a..1aeb3a101b 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -493,9 +493,8 @@ deriving instance Show AChatMsgEvent -- actual filtering on forwarding is done in processEvent isForwardedGroupMsg :: ChatMsgEvent e -> Bool isForwardedGroupMsg ev = case ev of - XMsgNew mc -> case mcExtMsgContent mc of - ExtMsgContent {file = Just FileInvitation {fileInline = Just _}} -> False - _ -> True + XMsgNew MsgContainer {file = Just FileInvitation {fileInline = Just _}} -> False + XMsgNew _ -> True XMsgFileDescr _ _ -> True XMsgUpdate {} -> True XMsgDel {} -> True @@ -510,6 +509,7 @@ isForwardedGroupMsg ev = case ev of XGrpDel -> True XGrpInfo _ -> True XGrpPrefs _ -> True + XMsgPrefs {} -> True _ -> False data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} @@ -598,7 +598,7 @@ data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent} cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg cmToQuotedMsg = \case - ACME _ (XMsgNew (MCQuote quotedMsg _)) -> Just quotedMsg + ACME _ (XMsgNew MsgContainer {quote = Just quotedMsg}) -> Just quotedMsg _ -> Nothing data MsgContentTag @@ -670,8 +670,10 @@ data MsgContainer = MsgContainer deriving (Eq, Show) -- Base value used by the smart constructors and for record-update on send sites. -mc :: MsgContainer -mc = +-- Named mcEmpty (not mc) to avoid shadowing the conventional local variable name +-- `mc` used at MsgContainer pattern-match sites across the codebase. +mcEmpty :: MsgContainer +mcEmpty = MsgContainer { content = MCText "", mentions = M.empty, @@ -686,16 +688,16 @@ mc = } mcSimple :: MsgContent -> MsgContainer -mcSimple c = mc {content = c} +mcSimple c = mcEmpty {content = c} mcQuote :: QuotedMsg -> MsgContent -> MsgContainer -mcQuote q c = mc {content = c, quote = Just q} +mcQuote q c = mcEmpty {content = c, quote = Just q} mcComment :: MsgRef -> MsgContent -> MsgContainer -mcComment p c = mc {content = c, parent = Just p} +mcComment p c = mcEmpty {content = c, parent = Just p} mcForward :: MsgContent -> MsgContainer -mcForward c = mc {content = c, forward = Just True} +mcForward c = mcEmpty {content = c, forward = Just True} isMCForward :: MsgContainer -> Bool isMCForward MsgContainer {forward} = forward == Just True @@ -748,7 +750,7 @@ msgContentHasText :: MsgContent -> Bool msgContentHasText = not . T.null . \case MCVoice {text} -> text - mc -> msgContentText mc + c -> msgContentText c isVoice :: MsgContent -> Bool isVoice = \case @@ -868,24 +870,26 @@ markCompressedBatch = B.cons 'X' {-# INLINE markCompressedBatch #-} parseMsgContainer :: J.Object -> JT.Parser MsgContainer -parseMsgContainer v = - MCQuote <$> v .: "quote" <*> mc - <|> MCComment <$> v .: "parent" <*> mc - <|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc) - -- The support for arbitrary object in "forward" property is added to allow - -- forward compatibility with forwards that include public group links. - <|> (MCForward <$> ((v .: "forward" :: JT.Parser J.Object) *> mc)) - <|> MCSimple <$> mc +parseMsgContainer v = do + content <- v .: "content" + file <- v .:? "file" + ttl <- v .:? "ttl" + live <- v .:? "live" + mentions <- fromMaybe M.empty <$> (v .:? "mentions") + scope <- v .:? "scope" + asGroup <- v .:? "asGroup" + quote <- v .:? "quote" + parent <- v .:? "parent" + forward <- (v .:? "forward") >>= parseForward + pure MsgContainer {content, mentions, file, ttl, live, scope, asGroup, quote, parent, forward} where - mc = do - content <- v .: "content" - file <- v .:? "file" - ttl <- v .:? "ttl" - live <- v .:? "live" - mentions <- fromMaybe M.empty <$> (v .:? "mentions") - scope <- v .:? "scope" - asGroup <- v .:? "asGroup" - pure ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} + -- Backward compatibility: legacy clients encode forward either as a Bool or as an + -- object (the latter is used by public group links). Any present form → Just True. + parseForward :: Maybe J.Value -> JT.Parser (Maybe Bool) + parseForward Nothing = pure Nothing + parseForward (Just (J.Bool b)) = pure (justTrue b) + parseForward (Just (J.Object _)) = pure (Just True) + parseForward (Just _) = fail "invalid forward field" justTrue :: Bool -> Maybe Bool justTrue True = Just True @@ -931,15 +935,15 @@ unknownMsgType :: Text unknownMsgType = "unknown message type" msgContainerJSON :: MsgContainer -> J.Object -msgContainerJSON = \case - MCQuote qm mc -> o $ ("quote" .= qm) : msgContent mc - MCComment ref mc -> o $ ("parent" .= ref) : msgContent mc - MCForward mc -> o $ ("forward" .= True) : msgContent mc - MCSimple mc -> o $ msgContent mc +msgContainerJSON MsgContainer {content, mentions, file, ttl, live, scope, asGroup, quote, parent, forward} = + JM.fromList $ + discriminators + <> ("file" .=? file) (("ttl" .=? ttl) (("live" .=? live) (("mentions" .=? nonEmptyMap mentions) (("scope" .=? scope) (("asGroup" .=? asGroup) ["content" .= content]))))) where - o = JM.fromList - msgContent ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} = - ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) $ ("scope" .=? scope) $ ("asGroup" .=? asGroup) ["content" .= content] + discriminators = + ["quote" .= q | Just q <- [quote]] + <> ["parent" .= p | Just p <- [parent]] + <> ["forward" .= True | forward == Just True] nonEmptyMap :: Map k v -> Maybe (Map k v) nonEmptyMap m = if M.null m then Nothing else Just m @@ -1342,6 +1346,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpDel_ -> pure XGrpDel XGrpInfo_ -> XGrpInfo <$> p "groupProfile" XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences" + XMsgPrefs_ -> XMsgPrefs <$> p "msgId" <*> p "comments" XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope" XGrpMsgForward_ -> do fwdSender <- opt "memberId" >>= \case @@ -1412,6 +1417,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en XGrpDel -> JM.empty XGrpInfo p -> o ["groupProfile" .= p] XGrpPrefs p -> o ["groupPreferences" .= p] + XMsgPrefs {msgId = msgId', comments} -> o ["msgId" .= msgId', "comments" .= comments] XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq] XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs] where diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 93fdf1868a..0d74ee43b3 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -2057,6 +2057,24 @@ checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO () deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId, groupId, memberProfile} = do deleteGroupMemberConnection db user m + -- Decrement parent comment counts for this member's live comments BEFORE the bulk DELETE. + -- Decrements of parents that themselves belong to this member are harmless no-ops + -- (the row vanishes immediately after). + decrements <- + DB.query + db + [sql| + SELECT parent_chat_item_id, COUNT(*) FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id = ? + AND parent_chat_item_id IS NOT NULL AND item_deleted = 0 + GROUP BY parent_chat_item_id + |] + (userId, groupId, groupMemberId) + forM_ (decrements :: [(ChatItemId, Int)]) $ \(pId, n) -> + DB.execute + db + "UPDATE chat_items SET comments_total = MAX(0, comments_total + ?) WHERE chat_item_id = ?" + (negate n, pId) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?" (userId, groupId, groupMemberId) DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) cleanupMemberProfileAndName_ db user m diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index a2c91af86b..2b8c0bb28a 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -48,6 +48,10 @@ module Simplex.Chat.Store.Messages getChatContentTypes, getDirectChat, getGroupChat, + getChannelMsgInfo, + getChannelMsgInfoBySharedMsgId, + adjustChannelMsgCommentCount, + setChannelMsgCommentsDisabled, getGroupChatScopeInfoForItem, getLocalChat, getDirectChatItemLast, @@ -535,9 +539,9 @@ setSupportChatMemberAttention db vr user g m memberAttention = do m_ <- runExceptT $ getGroupMemberById db vr user (groupMemberId' m) pure $ either (const m) id m_ -- Left shouldn't happen, but types require it -createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId -createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded timed live hasLink createdAt = - createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (MSSVerified <$ signedMsg_) createdAt +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded parentChatItemId_ timed live hasLink createdAt = + createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded parentChatItemId_ timed live False hasLink createdAt Nothing (MSSVerified <$ signedMsg_) createdAt where createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow @@ -551,10 +555,10 @@ createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) -createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) -createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do +createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) +createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent parentChatItemId_ timed live userMention hasLink itemTs createdAt = do let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False - ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt + ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded parentChatItemId_ timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg pure (ciId, quotedItem, itemForwarded) where @@ -573,19 +577,19 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgS createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink itemTs = - createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing Nothing + createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing Nothing False False hasLink itemTs Nothing Nothing where quoteRow :: NewQuoteRow quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) -createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do +createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> IO ChatItemId +createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded parentChatItemId_ timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do DB.execute db [sql| INSERT INTO chat_items ( -- user and IDs - user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id, + user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id, parent_chat_item_id, -- meta item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id, forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, item_viewed, show_group_as_sender, msg_signed, timed_ttl, timed_delete_at, @@ -593,11 +597,12 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, -- forwarded from fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((userId, msgId_) :. idsRow :. groupScopeRow :. itemRow :. quoteRow' :. forwardedFromRow) + ((userId, msgId_) :. idsRow :. groupScopeRow :. Only parentChatItemId_ :. itemRow :. quoteRow' :. forwardedFromRow) ciId <- insertedRowId db forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt + forM_ parentChatItemId_ $ \pId -> adjustChannelMsgCommentCount db pId 1 pure ciId where itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt, BoolInt, Maybe MsgSigStatus) :. (Maybe Int, Maybe UTCTime) @@ -623,8 +628,9 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share Just (Just GCSIMemberSupport {groupMember_}) -> (Just GCSTMemberSupport_, groupMemberId' <$> groupMember_) _ -> (Nothing, Nothing) includeInHistory :: Bool - includeInHistory = case groupScope of - Just Nothing -> isJust mcTag_ && mcTag_ /= Just MCReport_ + includeInHistory = case (groupScope, parentChatItemId_) of + (_, Just _) -> isJust mcTag_ && mcTag_ /= Just MCReport_ + (Just Nothing, Nothing) -> isJust mcTag_ && mcTag_ /= Just MCReport_ _ -> False itemViewed :: Bool itemViewed = case msgDirection @d of @@ -888,7 +894,7 @@ findGroupChatPreviews_ db User {userId} pagination clq = ( SELECT chat_item_id FROM chat_items ci - WHERE ci.user_id = ? AND ci.group_id = g.group_id AND ci.group_scope_tag IS NULL AND ci.group_scope_group_member_id IS NULL + WHERE ci.user_id = ? AND ci.group_id = g.group_id AND ci.group_scope_tag IS NULL AND ci.group_scope_group_member_id IS NULL AND ci.parent_chat_item_id IS NULL ORDER BY ci.item_ts DESC LIMIT 1 ) AS chat_item_id, @@ -901,13 +907,13 @@ findGroupChatPreviews_ db User {userId} pagination clq = LEFT JOIN ( SELECT group_id, COUNT(1) AS UnreadCount, SUM(user_mention) as UnreadMentions, MIN(chat_item_id) AS MinUnread FROM chat_items - WHERE user_id = ? AND group_id IS NOT NULL AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND item_status = ? + WHERE user_id = ? AND group_id IS NOT NULL AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL AND item_status = ? GROUP BY group_id ) ChatStats ON ChatStats.group_id = g.group_id LEFT JOIN ( SELECT group_id, COUNT(1) AS Count FROM chat_items - WHERE user_id = ? AND group_id IS NOT NULL + WHERE user_id = ? AND group_id IS NOT NULL AND parent_chat_item_id IS NULL AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0 GROUP BY group_id ) ReportCount ON ReportCount.group_id = g.group_id @@ -1071,7 +1077,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do -- this function can be changed so it never fails, not only avoid failure on invalid json toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal) -toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = +toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (parentChatItemId, commentsTotal, BI commentsDisabled) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = chatItem $ fromRight invalid $ dbParseACIContent itemContentText where invalid = ACIContent msgDir $ CIInvalidJSON itemContentText @@ -1104,7 +1110,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex _ -> Just (CIDeleted @'CTLocal deletedTs) itemEdited' = maybe False unBI itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow - in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt + in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -1199,7 +1205,7 @@ getChatContentTypes db User {userId} (ChatRef cType chatId chatScope_) = case cT CTDirect -> getTypes " contact_id = ? " () CTLocal -> getTypes " note_folder_id = ? " () CTGroup -> case chatScope_ of - Nothing -> getTypes " group_id = ? AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL " () + Nothing -> getTypes " group_id = ? AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL " () Just (GCSMemberSupport mId_) -> getTypes " group_id = ? AND group_scope_tag = ? AND group_scope_group_member_id IS NOT DISTINCT FROM ? " (GCSTMemberSupport_, mId_) _ -> throwError $ SEInternalError "unsupported chat type" where @@ -1228,7 +1234,7 @@ getDirectChat db vr user contactId contentFilter pagination search_ = do getDirectChatLast_ :: DB.Connection -> User -> Contact -> Maybe MsgContentTag -> Int -> Text -> ExceptT StoreError IO (Chat 'CTDirect) getDirectChatLast_ db user ct contentFilter count search = do let cInfo = DirectChat ct - ciIds <- getChatItemIDs db user cInfo contentFilter CRLast count search + ciIds <- getChatItemIDs db user cInfo Nothing contentFilter CRLast count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds pure $ Chat cInfo (reverse cis) emptyChatStats @@ -1285,7 +1291,7 @@ getDirectChatAfter_ db user ct@Contact {contactId} contentFilter afterId count s afterCI <- getDirectChatItem db user contactId afterId let cInfo = DirectChat ct range = CRAfter (ciCreatedAt afterCI) (cChatItemId afterCI) - ciIds <- getChatItemIDs db user cInfo contentFilter range count search + ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds pure $ Chat cInfo cis emptyChatStats @@ -1295,7 +1301,7 @@ getDirectChatBefore_ db user ct@Contact {contactId} contentFilter beforeId count beforeCI <- getDirectChatItem db user contactId beforeId let cInfo = DirectChat ct range = CRBefore (ciCreatedAt beforeCI) (cChatItemId beforeCI) - ciIds <- getChatItemIDs db user cInfo contentFilter range count search + ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds pure $ Chat cInfo (reverse cis) emptyChatStats @@ -1310,8 +1316,8 @@ getDirectChatAround' db user ct@Contact {contactId} contentFilter aroundId count aroundCI <- getDirectChatItem db user contactId aroundId let cInfo = DirectChat ct range r = r (ciCreatedAt aroundCI) (cChatItemId aroundCI) - beforeIds <- getChatItemIDs db user cInfo contentFilter (range CRBefore) count search - afterIds <- getChatItemIDs db user cInfo contentFilter (range CRAfter) count search + beforeIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRBefore) count search + afterIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRAfter) count search ts <- liftIO getCurrentTime beforeCIs <- liftIO $ mapM (safeGetDirectItem db user ct ts) beforeIds afterCIs <- liftIO $ mapM (safeGetDirectItem db user ct ts) afterIds @@ -1431,19 +1437,93 @@ getContactNavInfo_ db User {userId} Contact {contactId} afterCI = do :. (userId, contactId, ciCreatedAt afterCI, cChatItemId afterCI) ) -getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) -getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do +getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) +getGroupChat db vr user groupId scope_ parentChatItemId_ contentFilter pagination search_ = do + when (isJust scope_ && isJust parentChatItemId_) $ + throwError $ SEInternalError "group chat scope and parent chat item are mutually exclusive" let search = fromMaybe "" search_ g <- getGroupInfo db vr user groupId scopeInfo <- mapM (getCreateGroupChatScopeInfo db vr user g) scope_ + -- Validate parent post if comments thread is requested. + forM_ parentChatItemId_ $ \pId -> void $ getChannelMsgInfo db user groupId pId case pagination of - CPLast count -> (,Nothing) <$> getGroupChatLast_ db user g scopeInfo contentFilter count search emptyChatStats - CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g scopeInfo contentFilter afterId count search - CPBefore beforeId count -> (,Nothing) <$> getGroupChatBefore_ db user g scopeInfo contentFilter beforeId count search - CPAround aroundId count -> getGroupChatAround_ db user g scopeInfo contentFilter aroundId count search + CPLast count -> (,Nothing) <$> getGroupChatLast_ db user g scopeInfo parentChatItemId_ contentFilter count search emptyChatStats + CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g scopeInfo parentChatItemId_ contentFilter afterId count search + CPBefore beforeId count -> (,Nothing) <$> getGroupChatBefore_ db user g scopeInfo parentChatItemId_ contentFilter beforeId count search + CPAround aroundId count -> getGroupChatAround_ db user g scopeInfo parentChatItemId_ contentFilter aroundId count search CPInitial count -> do unless (T.null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search" - getGroupChatInitial_ db user g scopeInfo contentFilter count + getGroupChatInitial_ db user g scopeInfo parentChatItemId_ contentFilter count + +-- | Resolve a channel post by its local ChatItemId, returning both the post +-- itself and its SharedMsgId. Used by the send and receive paths to derive +-- the wire-side MsgRef while keeping the DB-side parent_chat_item_id linkage. +getChannelMsgInfo :: DB.Connection -> User -> GroupId -> ChatItemId -> ExceptT StoreError IO ChannelMsgInfo +getChannelMsgInfo db user groupId parentChatItemId = do + parent@(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) <- + getGroupChatItem db user groupId parentChatItemId + case itemSharedMsgId of + Just sId -> pure ChannelMsgInfo {channelMsgItem = parent, channelMsgSharedId = sId} + Nothing -> throwError $ SEChatItemNotFound parentChatItemId + +-- | Resolve a channel post by its wire SharedMsgId, returning both the post +-- itself and its SharedMsgId. Used by the receive path to look up the parent +-- post referenced by an incoming comment's MsgContainer.parent. +getChannelMsgInfoBySharedMsgId :: DB.Connection -> User -> GroupInfo -> SharedMsgId -> ExceptT StoreError IO ChannelMsgInfo +getChannelMsgInfoBySharedMsgId db user g sharedMsgId = do + parent <- getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId + pure ChannelMsgInfo {channelMsgItem = parent, channelMsgSharedId = sharedMsgId} + +-- | Increment or decrement the live comment count of a channel post. +-- Clamped at 0 to guard against transient negative counts under concurrent deletes. +adjustChannelMsgCommentCount :: DB.Connection -> ChatItemId -> Int -> IO () +adjustChannelMsgCommentCount db parentChatItemId delta = + DB.execute + db + "UPDATE chat_items SET comments_total = MAX(0, comments_total + ?) WHERE chat_item_id = ?" + (delta, parentChatItemId) + +-- | Persist the per-post comments-disabled flag. +setChannelMsgCommentsDisabled :: DB.Connection -> ChatItemId -> Bool -> IO () +setChannelMsgCommentsDisabled db parentChatItemId disabled = + DB.execute + db + "UPDATE chat_items SET comments_disabled = ? WHERE chat_item_id = ?" + (BI disabled, parentChatItemId) + +-- | Decrement parent comment counts for live comments by a given group member. +-- Used by batch member-removal paths (markMemberCIsDeleted, updateMemberCIsModerated) +-- before they bulk-mark items deleted, so comments_total stays accurate. +-- When member is the user's own membership, queries by item_sent = 1 AND group_member_id IS NULL. +-- Otherwise queries by group_member_id = ?. +-- Already-deleted comments are excluded so no double-decrement occurs. +decrementMemberCommentCounts_ :: DB.Connection -> UserId -> Int64 -> Bool -> GroupMemberId -> IO () +decrementMemberCommentCounts_ db userId groupId isMembership memId = do + decrements <- + if isMembership + then + DB.query + db + [sql| + SELECT parent_chat_item_id, COUNT(*) FROM chat_items + WHERE user_id = ? AND group_id = ? + AND group_member_id IS NULL AND item_sent = 1 + AND parent_chat_item_id IS NOT NULL AND item_deleted = 0 + GROUP BY parent_chat_item_id + |] + (userId, groupId) + else + DB.query + db + [sql| + SELECT parent_chat_item_id, COUNT(*) FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id = ? + AND parent_chat_item_id IS NOT NULL AND item_deleted = 0 + GROUP BY parent_chat_item_id + |] + (userId, groupId, memId) + forM_ (decrements :: [(ChatItemId, Int)]) $ \(pId, n) -> + adjustChannelMsgCommentCount db pId (negate n) getCreateGroupChatScopeInfo :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo getCreateGroupChatScopeInfo db vr user GroupInfo {membership} = \case @@ -1493,45 +1573,55 @@ getGroupChatScopeForItem_ db itemId = (Nothing, Nothing) -> Nothing (Nothing, Just _) -> Nothing -- shouldn't happen -getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatLast_ db user g scopeInfo_ contentFilter count search stats = do +getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatLast_ db user g scopeInfo_ parentChatItemId_ contentFilter count search stats = do let cInfo = GroupChat g scopeInfo_ - ciIds <- getChatItemIDs db user cInfo contentFilter CRLast count search + ciIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter CRLast count search ts <- liftIO getCurrentTime cis <- mapM (liftIO . safeGetGroupItem db user g ts) ciIds pure $ Chat cInfo (reverse cis) stats data ChatItemIDsRange = CRLast | CRAfter UTCTime ChatItemId | CRBefore UTCTime ChatItemId -getChatItemIDs :: DB.Connection -> User -> ChatInfo c -> Maybe MsgContentTag -> ChatItemIDsRange -> Int -> Text -> ExceptT StoreError IO [ChatItemId] -getChatItemIDs db User {userId} cInfo contentFilter range count search = case cInfo of - GroupChat GroupInfo {groupId} scopeInfo_ -> case (scopeInfo_, contentFilter) of - (Nothing, Nothing) -> +getChatItemIDs :: DB.Connection -> User -> ChatInfo c -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemIDsRange -> Int -> Text -> ExceptT StoreError IO [ChatItemId] +getChatItemIDs db User {userId} cInfo parentChatItemId_ contentFilter range count search = case cInfo of + GroupChat GroupInfo {groupId} scopeInfo_ -> case (scopeInfo_, parentChatItemId_, contentFilter) of + (Nothing, Nothing, Nothing) -> liftIO $ idsQuery - (grCond <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL ") + (grCond <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL ") (userId, groupId) "item_ts" - (Nothing, Just MCLink_) -> + (Nothing, Nothing, Just MCLink_) -> liftIO $ idsQuery - (grCond <> " AND has_link = 1 ") + (grCond <> " AND has_link = 1 AND parent_chat_item_id IS NULL ") (userId, groupId) "item_ts" - (Nothing, Just mcTag) -> + (Nothing, Nothing, Just mcTag) -> liftIO $ idsQuery - (grCond <> " AND msg_content_tag = ? ") + (grCond <> " AND msg_content_tag = ? AND parent_chat_item_id IS NULL ") (userId, groupId, mcTag) "item_ts" - (Just GCSIMemberSupport {groupMember_ = m}, Nothing) -> + (Just GCSIMemberSupport {groupMember_ = m}, Nothing, Nothing) -> liftIO $ idsQuery (grCond <> " AND group_scope_tag = ? AND group_scope_group_member_id IS NOT DISTINCT FROM ? ") (userId, groupId, GCSTMemberSupport_, groupMemberId' <$> m) "item_ts" - (Just _scope, Just _mcTag) -> + (Nothing, Just parentId, Nothing) -> + liftIO $ + idsQuery + (grCond <> " AND parent_chat_item_id = ? ") + (userId, groupId, parentId) + "item_ts" + (Just _scope, _, Just _mcTag) -> throwError $ SEInternalError "group scope and content filter are not supported together" + (Just _scope, Just _, _) -> + throwError $ SEInternalError "group scope and parent chat item are mutually exclusive" + (Nothing, Just _, Just _) -> + throwError $ SEInternalError "channel comments thread and content filter are not supported together" where grCond = " user_id = ? AND group_id = ? " DirectChat Contact {contactId} -> liftIO $ case contentFilter of @@ -1626,38 +1716,38 @@ getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do (userId, groupId, groupMemberId) getGroupChatItem db user groupId chatItemId -getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatAfter_ db user g@GroupInfo {groupId} scopeInfo contentFilter afterId count search = do +getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatAfter_ db user g@GroupInfo {groupId} scopeInfo parentChatItemId_ contentFilter afterId count search = do afterCI <- getGroupChatItem db user groupId afterId let cInfo = GroupChat g scopeInfo range = CRAfter (chatItemTs afterCI) (cChatItemId afterCI) - ciIds <- getChatItemIDs db user cInfo contentFilter range count search + ciIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter range count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetGroupItem db user g ts) ciIds pure $ Chat cInfo cis emptyChatStats -getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatBefore_ db user g@GroupInfo {groupId} scopeInfo contentFilter beforeId count search = do +getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatBefore_ db user g@GroupInfo {groupId} scopeInfo parentChatItemId_ contentFilter beforeId count search = do beforeCI <- getGroupChatItem db user groupId beforeId let cInfo = GroupChat g scopeInfo range = CRBefore (chatItemTs beforeCI) (cChatItemId beforeCI) - ciIds <- getChatItemIDs db user cInfo contentFilter range count search + ciIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter range count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetGroupItem db user g ts) ciIds pure $ Chat cInfo (reverse cis) emptyChatStats -getGroupChatAround_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) -getGroupChatAround_ db user g scopeInfo contentFilter aroundId count search = do +getGroupChatAround_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) +getGroupChatAround_ db user g scopeInfo parentChatItemId_ contentFilter aroundId count search = do stats <- getGroupStats_ db user g scopeInfo - getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stats + getGroupChatAround' db user g scopeInfo parentChatItemId_ contentFilter aroundId count search stats -getGroupChatAround' :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) -getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stats = do +getGroupChatAround' :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) +getGroupChatAround' db user g scopeInfo parentChatItemId_ contentFilter aroundId count search stats = do aroundCI <- getGroupCIWithReactions db user g aroundId let cInfo = GroupChat g scopeInfo range r = r (chatItemTs aroundCI) (cChatItemId aroundCI) - beforeIds <- getChatItemIDs db user cInfo contentFilter (range CRBefore) count search - afterIds <- getChatItemIDs db user cInfo contentFilter (range CRAfter) count search + beforeIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter (range CRBefore) count search + afterIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter (range CRAfter) count search ts <- liftIO getCurrentTime beforeCIs <- liftIO $ mapM (safeGetGroupItem db user g ts) beforeIds afterCIs <- liftIO $ mapM (safeGetGroupItem db user g ts) afterIds @@ -1669,17 +1759,23 @@ getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stat [] -> pure $ NavigationInfo 0 0 cis -> getGroupNavInfo_ db user g (last cis) -getGroupChatInitial_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Int -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) -getGroupChatInitial_ db user g scopeInfo_ contentFilter count = do - getGroupMinUnreadId_ db user g scopeInfo_ contentFilter >>= \case - Just minUnreadItemId -> do - unreadCounts <- getGroupUnreadCount_ db user g scopeInfo_ Nothing - stats <- liftIO $ getStats minUnreadItemId unreadCounts - pivotId <- fromMaybe minUnreadItemId <$> getGroupMaxViewedItemId_ db user g scopeInfo_ contentFilter - getGroupChatAround' db user g scopeInfo_ contentFilter pivotId count "" stats - Nothing -> do +getGroupChatInitial_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> Int -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo) +getGroupChatInitial_ db user g scopeInfo_ parentChatItemId_ contentFilter count = do + -- Comments threads have no unread tracking; fall through to a "last" page directly. + case parentChatItemId_ of + Just _ -> do stats <- liftIO $ getStats 0 (0, 0) - (,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g scopeInfo_ contentFilter count "" stats + (,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g scopeInfo_ parentChatItemId_ contentFilter count "" stats + Nothing -> + getGroupMinUnreadId_ db user g scopeInfo_ contentFilter >>= \case + Just minUnreadItemId -> do + unreadCounts <- getGroupUnreadCount_ db user g scopeInfo_ Nothing + stats <- liftIO $ getStats minUnreadItemId unreadCounts + pivotId <- fromMaybe minUnreadItemId <$> getGroupMaxViewedItemId_ db user g scopeInfo_ contentFilter + getGroupChatAround' db user g scopeInfo_ parentChatItemId_ contentFilter pivotId count "" stats + Nothing -> do + stats <- liftIO $ getStats 0 (0, 0) + (,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g scopeInfo_ parentChatItemId_ contentFilter count "" stats where getStats minUnreadItemId (unreadCount, unreadMentions) = do reportsCount <- getGroupReportsCount_ db user g False @@ -1720,7 +1816,7 @@ getGroupReportsCount_ db User {userId} GroupInfo {groupId} archived = fromOnly . head <$> DB.query db - "SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0" + "SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? AND parent_chat_item_id IS NULL AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0" (userId, groupId, MCReport_, BI archived) queryUnreadGroupItems :: (ToField p, FromRow r) => DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Query -> p -> Query -> Query -> ExceptT StoreError IO [r] @@ -1730,13 +1826,13 @@ queryUnreadGroupItems db User {userId} GroupInfo {groupId} scopeInfo_ contentFil liftIO $ DB.query db - (baseQuery <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND " <> statusCond <> orderLimit) + (baseQuery <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL AND " <> statusCond <> orderLimit) (userId, groupId, statusParam) (Nothing, Just mcTag) -> liftIO $ DB.query db - (baseQuery <> " AND msg_content_tag = ? AND " <> statusCond <> orderLimit) + (baseQuery <> " AND parent_chat_item_id IS NULL AND msg_content_tag = ? AND " <> statusCond <> orderLimit) (userId, groupId, mcTag, statusParam) (Just GCSIMemberSupport {groupMember_ = m}, Nothing) -> liftIO $ @@ -1814,7 +1910,7 @@ getLocalChat db user folderId contentFilter pagination search_ = do getLocalChatLast_ :: DB.Connection -> User -> NoteFolder -> Maybe MsgContentTag -> Int -> Text -> ExceptT StoreError IO (Chat 'CTLocal) getLocalChatLast_ db user nf contentFilter count search = do let cInfo = LocalChat nf - ciIds <- getChatItemIDs db user cInfo contentFilter CRLast count search + ciIds <- getChatItemIDs db user cInfo Nothing contentFilter CRLast count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds pure $ Chat cInfo (reverse cis) emptyChatStats @@ -1851,7 +1947,7 @@ getLocalChatAfter_ db user nf@NoteFolder {noteFolderId} contentFilter afterId co afterCI <- getLocalChatItem db user noteFolderId afterId let cInfo = LocalChat nf range = CRAfter (ciCreatedAt afterCI) (cChatItemId afterCI) - ciIds <- getChatItemIDs db user cInfo contentFilter range count search + ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds pure $ Chat cInfo cis emptyChatStats @@ -1861,7 +1957,7 @@ getLocalChatBefore_ db user nf@NoteFolder {noteFolderId} contentFilter beforeId beforeCI <- getLocalChatItem db user noteFolderId beforeId let cInfo = LocalChat nf range = CRBefore (ciCreatedAt beforeCI) (cChatItemId beforeCI) - ciIds <- getChatItemIDs db user cInfo contentFilter range count search + ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search ts <- liftIO getCurrentTime cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds pure $ Chat cInfo (reverse cis) emptyChatStats @@ -1876,8 +1972,8 @@ getLocalChatAround' db user nf@NoteFolder {noteFolderId} contentFilter aroundId aroundCI <- getLocalChatItem db user noteFolderId aroundId let cInfo = LocalChat nf range r = r (ciCreatedAt aroundCI) (cChatItemId aroundCI) - beforeIds <- getChatItemIDs db user cInfo contentFilter (range CRBefore) count search - afterIds <- getChatItemIDs db user cInfo contentFilter (range CRAfter) count search + beforeIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRBefore) count search + afterIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRAfter) count search ts <- liftIO getCurrentTime beforeCIs <- liftIO $ mapM (safeGetLocalItem db user nf ts) beforeIds afterCIs <- liftIO $ mapM (safeGetLocalItem db user nf ts) afterIds @@ -2071,6 +2167,7 @@ updateGroupChatItemsRead db User {userId} GroupInfo {groupId} = do [sql| UPDATE chat_items SET item_status = ?, item_viewed = 1, updated_at = ? WHERE user_id = ? AND group_id = ? + AND parent_chat_item_id IS NULL AND item_status = ? |] (CISRcvRead, currentTs, userId, groupId, CISRcvNew) @@ -2127,6 +2224,7 @@ getGroupUnreadTimedItems db User {userId} groupId scope = SELECT chat_item_id, timed_ttl FROM chat_items WHERE user_id = ? AND group_id = ? + AND parent_chat_item_id IS NULL AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL |] (userId, groupId, CISRcvNew) @@ -2260,6 +2358,7 @@ type ChatItemRow = :. (Int, Maybe UTCTime, Maybe BoolInt, UTCTime, UTCTime) :. ChatItemForwardedFromRow :. ChatItemModeRow + :. (Maybe ChatItemId, Int, BoolInt) :. MaybeCIFIleRow type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe BoolInt) @@ -2275,7 +2374,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir -- this function can be changed so it never fails, not only avoid failure on invalid json toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = +toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (parentChatItemId, commentsTotal, BI commentsDisabled) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = chatItem $ fromRight invalid $ dbParseACIContent itemContentText where invalid = ACIContent msgDir $ CIInvalidJSON itemContentText @@ -2308,7 +2407,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT _ -> Just (CIDeleted @'CTDirect deletedTs) itemEdited' = maybe False unBI itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow - in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt + in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -2347,6 +2446,7 @@ toGroupChatItem :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) + :. (parentChatItemId, commentsTotal, BI commentsDisabled) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_) ) :. (forwardedByMember, BI showGroupAsSender) @@ -2397,7 +2497,7 @@ toGroupChatItem _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) itemEdited' = maybe False unBI itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow - in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt + in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -2671,6 +2771,8 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, + -- ChannelComments + i.parent_chat_item_id, i.comments_total, i.comments_disabled, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- DirectQuote @@ -2780,8 +2882,9 @@ updateGroupCIMentions db g ci@ChatItem {mentions} mentions' createMentions = createGroupCIMentions db g ci mentions' deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO () -deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do - let itemId = chatItemId' ci +deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci@ChatItem {meta} = do + let CIMeta {parentChatItemId, itemDeleted} = meta + itemId = chatItemId' ci deleteChatItemMessages_ db itemId deleteChatItemVersions_ db itemId deleteGroupCIReactions_ db g ci @@ -2792,11 +2895,16 @@ deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (userId, groupId, itemId) + -- Decrement parent's live comment count when a non-deleted comment is hard-deleted. + -- Already-soft-deleted comments were decremented at soft-delete time. + forM_ parentChatItemId $ \pId -> + when (isNothing itemDeleted) $ adjustChannelMsgCommentCount db pId (-1) updateGroupChatItemModerated :: forall d. MsgDirectionI d => DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d) -updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMember {groupMemberId} deletedTs = do +updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci@ChatItem {meta} m@GroupMember {groupMemberId} deletedTs = do currentTs <- getCurrentTime - let toContent = msgDirToModeratedContent_ $ msgDirection @d + let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta + toContent = msgDirToModeratedContent_ $ msgDirection @d toText = ciModeratedText itemId = chatItemId' ci deleteChatItemMessages_ db itemId @@ -2810,10 +2918,16 @@ updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMemb WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) - pure ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing} + -- Decrement parent's live comment count when a moderator soft-deletes a comment. + -- Already-deleted comments were decremented at first soft-delete time. + forM_ parentChatItemId $ \pId -> + when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1) + pure ci {content = toContent, meta = meta {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing} updateMemberCIsModerated :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> UTCTime -> IO () updateMemberCIsModerated db User {userId} GroupInfo {groupId, membership} member byGroupMember md deletedTs = do + -- Decrement parent comment counts BEFORE the bulk UPDATE marks comments deleted. + decrementMemberCommentCounts_ db userId groupId (memId == groupMemberId' membership) memId itemIds <- updateCIs =<< getCurrentTime #if defined(dbPostgres) let inItemIds = Only $ In (map fromOnly itemIds) @@ -2847,9 +2961,10 @@ updateMemberCIsModerated db User {userId} GroupInfo {groupId, membership} member columns = (deletedTs, groupMemberId' byGroupMember, msgDirToModeratedContent_ md, ciModeratedText, currentTs) updateGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO (ChatItem 'CTGroup d) -updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = do +updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta} deletedTs = do currentTs <- getCurrentTime - let itemId = chatItemId' ci + let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta + itemId = chatItemId' ci deleteChatItemMessages_ db itemId deleteChatItemVersions_ db itemId liftIO $ @@ -2861,7 +2976,10 @@ updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (DBCIBlockedByAdmin, deletedTs, currentTs, userId, groupId, itemId) - pure $ ci {meta = (meta ci) {itemDeleted = Just (CIBlockedByAdmin $ Just deletedTs), editable = False, deletable = False}, formattedText = Nothing} + -- Decrement parent's live comment count when a comment is blocked by admin. + forM_ parentChatItemId $ \pId -> + when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1) + pure $ ci {meta = meta {itemDeleted = Just (CIBlockedByAdmin $ Just deletedTs), editable = False, deletable = False}, formattedText = Nothing} pattern DBCINotDeleted :: Int pattern DBCINotDeleted = 0 @@ -2878,7 +2996,8 @@ pattern DBCIBlockedByAdmin = 3 markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d) markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} byGroupMember_ deletedTs = do currentTs <- liftIO getCurrentTime - let itemId = chatItemId' ci + let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta + itemId = chatItemId' ci (deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m) _ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs)) @@ -2890,10 +3009,15 @@ markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (DBCIDeleted, deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) + -- Decrement parent's live comment count on first soft-delete of a comment. + forM_ parentChatItemId $ \pId -> + when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1) pure ci {meta = meta {itemDeleted, editable = False, deletable = False}} markMemberCIsDeleted :: DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO () -markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byGroupMember deletedTs = +markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byGroupMember deletedTs = do + -- Decrement parent comment counts BEFORE the bulk UPDATE marks comments deleted. + decrementMemberCommentCounts_ db userId groupId (memId == groupMemberId' membership) memId updateCIs =<< getCurrentTime where memId = groupMemberId' member @@ -2920,6 +3044,7 @@ markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byG markGroupChatItemBlocked :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv) markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do deletedTs <- getCurrentTime + let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta DB.execute db [sql| @@ -2928,11 +3053,15 @@ markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (DBCIBlocked, deletedTs, deletedTs, userId, groupId, chatItemId' ci) + -- Decrement parent's live comment count when a comment is locally blocked. + forM_ parentChatItemId $ \pId -> + when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1) pure ci {meta = meta {itemDeleted = Just $ CIBlocked $ Just deletedTs, editable = False, deletable = False}} markGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv) markGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do deletedTs <- getCurrentTime + let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta DB.execute db [sql| @@ -2941,6 +3070,9 @@ markGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (DBCIBlockedByAdmin, deletedTs, deletedTs, userId, groupId, chatItemId' ci) + -- Decrement parent's live comment count when a comment is blocked by admin. + forM_ parentChatItemId $ \pId -> + when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1) pure ci {meta = meta {itemDeleted = Just $ CIBlockedByAdmin $ Just deletedTs, editable = False, deletable = False}} markMessageReportsDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO [ChatItemId] @@ -3026,6 +3158,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, + -- ChannelComments + i.parent_chat_item_id, i.comments_total, i.comments_disabled, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- CIMeta forwardedByMember, showGroupAsSender @@ -3135,6 +3269,8 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, + -- ChannelComments + i.parent_chat_item_id, i.comments_total, i.comments_disabled, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol FROM chat_items i @@ -3541,6 +3677,22 @@ deleteGroupExpiredCIs :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTim deleteGroupExpiredCIs db User {userId} GroupInfo {groupId} expirationDate createdAtCutoff = do DB.execute db "DELETE FROM messages WHERE group_id = ? AND created_at <= ?" (groupId, min expirationDate createdAtCutoff) DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ? AND reaction_ts <= ? AND created_at <= ?" (groupId, expirationDate, createdAtCutoff) + -- Decrement parent comment counts for expiring live comments BEFORE the bulk DELETE. + -- Decrements of parents that are themselves being deleted are harmless no-ops + -- (the row vanishes immediately after). + decrements <- + DB.query + db + [sql| + SELECT parent_chat_item_id, COUNT(*) FROM chat_items + WHERE user_id = ? AND group_id = ? + AND parent_chat_item_id IS NOT NULL AND item_deleted = 0 + AND item_ts <= ? AND created_at <= ? + GROUP BY parent_chat_item_id + |] + (userId, groupId, expirationDate, createdAtCutoff) + forM_ (decrements :: [(ChatItemId, Int)]) $ \(pId, n) -> + adjustChannelMsgCommentCount db pId (negate n) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_ts <= ? AND created_at <= ? AND item_content_tag != 'chatBanner'" (userId, groupId, expirationDate, createdAtCutoff) createCIModeration :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> MessageId -> UTCTime -> IO () diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 3a75a00a20..6bc0496aff 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -279,6 +279,14 @@ chatGroupTests = do it "should compute sendAsGroup in CLI forward" testForwardCLISendAsGroup it "should update member message in channel" testChannelMemberMessageUpdate it "should delete member message in channel" testChannelMemberMessageDelete + describe "channel comments" $ do + it "subscriber should comment on channel post" testChannelCommentSubscriberCanComment + it "should reject comment in non-channel group" testChannelCommentNotInRegularGroup + it "should reject comment when comments disabled on post" testChannelCommentDisabledRejected + it "subscriber should edit and delete own comment" testChannelCommentEditDelete + it "comments_total should increment on insert and decrement on delete" testChannelCommentCountIncrement + it "observer should not be able to comment" testChannelCommentObserverRejected + it "comments should not appear in main channel pagination" testChannelCommentMainChatExclusion testGroupCheckMessages :: HasCallStack => TestParams -> IO () testGroupCheckMessages = @@ -9877,6 +9885,260 @@ testChannelMemberMessageDelete ps = eve <# "#team cath> [marked deleted] hello" ] +testChannelCommentSubscriberCanComment :: HasCallStack => TestParams -> IO () +testChannelCommentSubscriberCanComment 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 [>>]" + + -- subscriber comments on the post + parentId <- lastItemId cath + cath ##> ("/_comment #1 " <> parentId <> " text reply") + cath <# "#team reply" + bob <# "#team cath> reply" + concurrentlyN_ + [ alice <# "#team cath> reply [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> reply [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> reply [>>]" + ] + +testChannelCommentNotInRegularGroup :: HasCallStack => TestParams -> IO () +testChannelCommentNotInRegularGroup = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + alice #> "#team hello" + [bob, cath] *<# "#team alice> hello" + parentId <- lastItemId bob + bob ##> ("/_comment #1 " <> parentId <> " text reply") + bob <## "bad chat command: comments are only supported in channel groups" + +testChannelCommentDisabledRejected :: HasCallStack => TestParams -> IO () +testChannelCommentDisabledRejected 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 + + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- owner disables comments on the post + aliceParentId <- lastItemId alice + alice ##> ("/_comments_disabled #1 " <> aliceParentId <> " on") + alice <## "ok" + + -- owner's own comment attempt is rejected (local state updated) + alice ##> ("/_comment #1 " <> aliceParentId <> " text reply") + alice <## "bad chat command: feature not allowed Comments" + +testChannelCommentEditDelete :: HasCallStack => TestParams -> IO () +testChannelCommentEditDelete 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 + + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- cath comments on the post + cathParentId <- lastItemId cath + cath ##> ("/_comment #1 " <> cathParentId <> " text reply") + cath <# "#team reply" + bob <# "#team cath> reply" + concurrentlyN_ + [ alice <# "#team cath> reply [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> reply [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> reply [>>]" + ] + + -- cath edits her own comment + cathCommentId <- lastItemId cath + cath ##> ("/_update item #1 " <> cathCommentId <> " text reply edited") + cath <# "#team [edited] reply edited" + bob <# "#team cath> [edited] reply edited" + concurrentlyN_ + [ alice <# "#team cath> [edited] reply edited", + dan <# "#team cath> [edited] reply edited", + eve <# "#team cath> [edited] reply edited" + ] + + -- cath deletes her own comment + cath #$> ("/_delete item #1 " <> cathCommentId <> " broadcast", id, "message marked deleted") + bob <# "#team cath> [marked deleted] reply edited" + concurrentlyN_ + [ alice <# "#team cath> [marked deleted] reply edited", + dan <# "#team cath> [marked deleted] reply edited", + eve <# "#team cath> [marked deleted] reply edited" + ] + +testChannelCommentCountIncrement :: HasCallStack => TestParams -> IO () +testChannelCommentCountIncrement 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 + + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + aliceParentId <- lastGroupItemId alice 1 + cathParentId <- lastGroupItemId cath 1 + danParentId <- lastGroupItemId dan 1 + -- no comments yet + getCommentsTotal alice aliceParentId `shouldReturn` 0 + + -- cath comments (capture cath's comment id immediately for later delete) + cath ##> ("/_comment #1 " <> cathParentId <> " text reply one") + cath <# "#team reply one" + cathCommentId <- lastGroupItemId cath 1 + bob <# "#team cath> reply one" + concurrentlyN_ + [ alice <# "#team cath> reply one [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> reply one [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> reply one [>>]" + ] + getCommentsTotal alice aliceParentId `shouldReturn` 1 + + -- dan comments on the parent (danParentId captured before cath's comment) + dan ##> ("/_comment #1 " <> danParentId <> " text reply two") + dan <# "#team reply two" + bob <# "#team dan> reply two" + concurrentlyN_ + [ alice <# "#team dan> reply two [>>]", + do + cath <## "#team: bob forwarded a message from an unknown member, creating unknown member record dan" + cath <# "#team dan> reply two [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record dan" + eve <# "#team dan> reply two [>>]" + ] + getCommentsTotal alice aliceParentId `shouldReturn` 2 + + -- cath soft-deletes her own comment + cath #$> ("/_delete item #1 " <> cathCommentId <> " broadcast", id, "message marked deleted") + bob <# "#team cath> [marked deleted] reply one" + concurrentlyN_ + [ alice <# "#team cath> [marked deleted] reply one", + dan <# "#team cath> [marked deleted] reply one", + eve <# "#team cath> [marked deleted] reply one" + ] + getCommentsTotal alice aliceParentId `shouldReturn` 1 + where + getCommentsTotal cc parentId = do + rows <- + withCCTransaction cc $ \db -> + DB.query db "SELECT comments_total FROM chat_items WHERE chat_item_id = ?" (Only parentId) :: IO [[Int]] + case rows of + [[n]] -> pure n + _ -> error $ "unexpected rows for comments_total: " <> show rows + +testChannelCommentObserverRejected :: HasCallStack => TestParams -> IO () +testChannelCommentObserverRejected 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 + + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- make cath known to other subscribers + cath #> "#team hi from cath" + bob <# "#team cath> hi from cath" + concurrentlyN_ + [ alice <# "#team cath> hi from cath [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> hi from cath [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> hi from cath [>>]" + ] + + -- alice demotes cath to observer + threadDelay 1000000 + 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's comment attempt is rejected by local role check + cathParentId <- lastGroupItemId cath 1 + cath ##> ("/_comment #1 " <> cathParentId <> " text reply") + cath <## "#team: you have insufficient permissions for this action, the required role is commenter" + +testChannelCommentMainChatExclusion :: HasCallStack => TestParams -> IO () +testChannelCommentMainChatExclusion 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 + + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + cathParentId <- lastGroupItemId cath 1 + cath ##> ("/_comment #1 " <> cathParentId <> " text reply") + cath <# "#team reply" + bob <# "#team cath> reply" + concurrentlyN_ + [ alice <# "#team cath> reply [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> reply [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> reply [>>]" + ] + + -- main channel pagination must show the parent post as the most recent text item, + -- not the comment that was just sent — comments are excluded from main pagination. + -- content=text filters out connection / feature events which are not message content. + alice #$> ("/_get chat #1 content=text count=1", chat, [(1, "hello")]) + bob #$> ("/_get chat #1 content=text count=1", chat, [(0, "hello")]) + cath #$> ("/_get chat #1 content=text count=1", chat, [(0, "hello")]) + testGroupLinkContentFilter :: HasCallStack => TestParams -> IO () testGroupLinkContentFilter = testChat3 aliceProfile bobProfile cathProfile $ diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 8acdb78b34..0a14848796 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -698,6 +698,25 @@ lastItemId cc = do cc ##> "/last_item_id" getTermLine' (Just "last item id") cc +-- Highest chat_item_id in the given group. Uses chat_item_id DESC ordering +-- (strictly monotonic via autoincrement), not item_ts, which can reverse +-- between a local "connected" event and an incoming message due to clock +-- skew across members. Captures any item type, including comments — use +-- this to capture a comment id right after sending, since the default +-- group pagination filters out rows with parent_chat_item_id set. +lastGroupItemId :: HasCallStack => TestCC -> Int -> IO String +lastGroupItemId cc gId = do + rows <- + withCCTransaction cc $ \db -> + DB.query + db + "SELECT chat_item_id FROM chat_items WHERE group_id = ? ORDER BY chat_item_id DESC LIMIT 1" + (Only gId) :: + IO [Only Int] + case rows of + [Only n] -> pure (show n) + _ -> error "lastGroupItemId: no items in group" + showActiveUser :: HasCallStack => TestCC -> String -> Expectation showActiveUser cc name = do cc <## ("user profile: " <> name) diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 1b708a2ffa..cb71318977 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module ProtocolTests where @@ -101,7 +102,7 @@ testChatPreferences :: Maybe Preferences testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, files = Nothing, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing, reactions = Just ReactionsPreference {allow = FAYes}, sessions = Nothing, commands = Nothing} testGroupPreferences :: Maybe GroupPreferences -testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn, role = Nothing}, files = Nothing, fullDelete = Nothing, simplexLinks = Nothing, history = Nothing, reports = Nothing, sessions = Nothing, commands = Nothing} +testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn, role = Nothing}, files = Nothing, fullDelete = Nothing, simplexLinks = Nothing, history = Nothing, reports = Nothing, sessions = Nothing, comments = Nothing, commands = Nothing} testProfile :: Profile testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences} @@ -113,73 +114,69 @@ decodeChatMessageTest :: Spec decodeChatMessageTest = describe "Chat message encoding/decoding" $ do it "x.msg.new simple text" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" - #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)) + #==# XMsgNew (mcSimple (MCText "hello")) it "x.msg.new simple text - timed message TTL" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}" - #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing Nothing Nothing)) + #==# XMsgNew (mcSimple (MCText "hello")) {ttl = Just 3600} it "x.msg.new simple text - live message" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}" - #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True) Nothing Nothing)) + #==# XMsgNew (mcSimple (MCText "hello")) {live = Just True} it "x.msg.new simple link" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}" - #==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing)) + #==# XMsgNew (mcSimple (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing})) it "x.msg.new simple image" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}}" - #==# XMsgNew (MCSimple (extMsgContent (MCImage "" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing)) + #==# XMsgNew (mcSimple (MCImage "" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=")) it "x.msg.new simple image with text" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"here's an image\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}}" - #==# XMsgNew (MCSimple (extMsgContent (MCImage "here's an image" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing)) + #==# XMsgNew (mcSimple (MCImage "here's an image" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=")) it "x.msg.new chat message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (mcSimple (MCText "hello"))) it "x.msg.new chat message with chat version range" $ - "{\"v\":\"1-17\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" - ##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))) + "{\"v\":\"1-18\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" + ##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (mcSimple (MCText "hello"))) it "x.msg.new quote" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing))) + (XMsgNew (mcQuote quotedMsg (MCText "hello to you too"))) it "x.msg.new quote - timed message TTL" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"ttl\":3600}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing (Just 3600) Nothing Nothing Nothing))) + (XMsgNew (mcQuote quotedMsg (MCText "hello to you too")) {ttl = Just 3600}) it "x.msg.new quote - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing Nothing (Just True) Nothing Nothing))) + (XMsgNew (mcQuote quotedMsg (MCText "hello to you too")) {live = Just True}) it "x.msg.new forward" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ mcForward (MCText "hello")) it "x.msg.new forward - timed message TTL" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing Nothing Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ (mcForward (MCText "hello")) {ttl = Just 3600}) it "x.msg.new forward - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True) Nothing Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ (mcForward (MCText "hello")) {live = Just True}) it "x.msg.new simple text with file" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" - #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) + #==# XMsgNew (mcSimple (MCText "hello")) {file = Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}} it "x.msg.new simple file with file" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"\",\"type\":\"file\"},\"file\":{\"fileSize\":12345,\"fileName\":\"file.txt\"}}}" - #==# XMsgNew (MCSimple (extMsgContent (MCFile "") (Just FileInvitation {fileName = "file.txt", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) + #==# XMsgNew (mcSimple (MCFile "")) {file = Just FileInvitation {fileName = "file.txt", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}} it "x.msg.new quote with file" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") ( XMsgNew - ( MCQuote - quotedMsg - ( extMsgContent - (MCText "hello to you too") - (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}) - ) + ( (mcQuote quotedMsg (MCText "hello to you too")) + {file = Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}} ) ) it "x.msg.new report" $ @@ -187,10 +184,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (extMsgContent (MCReport "" RRSpam) Nothing))) + (XMsgNew (mcQuote quotedMsg (MCReport "" RRSpam))) it "x.msg.new forward with file" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ (mcForward (MCText "hello")) {file = Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}}) it "x.msg.update" $ "{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing Nothing Nothing @@ -249,13 +246,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.new with member chat version range" $ - "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-18\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro with member chat version range" $ - "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-18\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro with member restrictions" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberRestrictions\":{\"restriction\":\"blocked\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" @@ -270,7 +267,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"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\"}}}}}}" #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq} it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $ - "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"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%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"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%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-18\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing} it "x.grp.mem.info" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}" @@ -300,7 +297,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do -- $ "{\"v\":\"1\",\"event\":\"x.grp.msg.forward\",\"params\":{\"msgForward\":{\"memberId\":\"AQIDBA==\",\"msg\":\"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}\",\"msgTs\":\"1970-01-01T00:00:01.000000001Z\"}}}" -- #==# XGrpMsgForward -- (MemberId "\1\2\3\4") - -- (ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)))) + -- (ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (mcSimple (MCText "hello")))) -- (systemToUTCTime $ MkSystemTime 1 1) it "x.info.probe" $ "{\"v\":\"1\",\"event\":\"x.info.probe\",\"params\":{\"probe\":\"AQIDBA==\"}}"