diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c4317c85c7..da1a9a7dcc 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -130,6 +130,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260122_has_link Simplex.Chat.Store.Postgres.Migrations.M20260222_chat_relays Simplex.Chat.Store.Postgres.Migrations.M20260403_item_viewed + Simplex.Chat.Store.Postgres.Migrations.M20260407_channel_comments else exposed-modules: Simplex.Chat.Archive @@ -282,6 +283,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260122_has_link Simplex.Chat.Store.SQLite.Migrations.M20260222_chat_relays Simplex.Chat.Store.SQLite.Migrations.M20260403_item_viewed + Simplex.Chat.Store.SQLite.Migrations.M20260407_channel_comments other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index e404388d8d..5ac69871f8 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -158,12 +158,22 @@ chatTypeStr = \case chatNameStr :: ChatName -> String chatNameStr (ChatName cType name) = T.unpack $ chatTypeStr cType <> if T.any isSpace name then "'" <> name <> "'" else name -data ChatRef = ChatRef {chatType :: ChatType, chatId :: Int64, chatScope :: Maybe GroupChatScope} +data ChatRef = ChatRef + { chatType :: ChatType, + chatId :: Int64, + chatScope :: Maybe GroupChatScope, + -- Set when referring to the comments thread of a specific channel post. + -- Mutually exclusive with chatScope at the call site. + channelMsg_ :: Maybe ChatItemId + } deriving (Eq, Show, Ord) data ChatInfo (c :: ChatType) where DirectChat :: Contact -> ChatInfo 'CTDirect - GroupChat :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup + -- The third parameter `Maybe ChannelMsgInfo` identifies the comments thread of a + -- specific channel post; it is `Nothing` for the main channel chat and for the + -- member-support scope. The two `Maybe` fields are mutually exclusive in practice. + GroupChat :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChannelMsgInfo -> ChatInfo 'CTGroup LocalChat :: NoteFolder -> ChatInfo 'CTLocal ContactRequest :: UserContactRequest -> ChatInfo 'CTContactRequest ContactConnection :: PendingContactConnection -> ChatInfo 'CTContactConnection @@ -174,6 +184,16 @@ deriving instance Show (ChatInfo c) data GroupChatScopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember} deriving (Show) +-- Identifies the parent channel post of a comments thread. +-- Both fields are co-determined: the SharedMsgId is extracted from `channelMsgItem` +-- by the smart constructor in Store/Messages.hs, so the field is total at the +-- type-system level. +data ChannelMsgInfo = ChannelMsgInfo + { channelMsgItem :: CChatItem 'CTGroup, + channelMsgSharedId :: SharedMsgId + } + deriving (Show) + toChatScope :: GroupChatScopeInfo -> GroupChatScope toChatScope = \case GCSIMemberSupport {groupMember_} -> GCSMemberSupport $ groupMemberId' <$> groupMember_ @@ -184,21 +204,22 @@ toMsgScope GroupInfo {membership} = \case chatInfoToRef :: ChatInfo c -> Maybe ChatRef chatInfoToRef = \case - DirectChat Contact {contactId} -> Just $ ChatRef CTDirect contactId Nothing - GroupChat GroupInfo {groupId} scopeInfo -> Just $ ChatRef CTGroup groupId (toChatScope <$> scopeInfo) - LocalChat NoteFolder {noteFolderId} -> Just $ ChatRef CTLocal noteFolderId Nothing - ContactRequest UserContactRequest {contactRequestId} -> Just $ ChatRef CTContactRequest contactRequestId Nothing - ContactConnection PendingContactConnection {pccConnId} -> Just $ ChatRef CTContactConnection pccConnId Nothing + DirectChat Contact {contactId} -> Just $ ChatRef CTDirect contactId Nothing Nothing + GroupChat GroupInfo {groupId} scopeInfo channelMsgInfo -> + Just $ ChatRef CTGroup groupId (toChatScope <$> scopeInfo) (cChatItemId . channelMsgItem <$> channelMsgInfo) + LocalChat NoteFolder {noteFolderId} -> Just $ ChatRef CTLocal noteFolderId Nothing Nothing + ContactRequest UserContactRequest {contactRequestId} -> Just $ ChatRef CTContactRequest contactRequestId Nothing Nothing + ContactConnection PendingContactConnection {pccConnId} -> Just $ ChatRef CTContactConnection pccConnId Nothing Nothing CInfoInvalidJSON {} -> Nothing chatInfoMembership :: ChatInfo c -> Maybe GroupMember chatInfoMembership = \case - GroupChat GroupInfo {membership} _scopeInfo -> Just membership + GroupChat GroupInfo {membership} _scopeInfo _channelMsgInfo -> Just membership _ -> Nothing data JSONChatInfo = JCInfoDirect {contact :: Contact} - | JCInfoGroup {groupInfo :: GroupInfo, groupChatScope :: Maybe GroupChatScopeInfo} + | JCInfoGroup {groupInfo :: GroupInfo, groupChatScope :: Maybe GroupChatScopeInfo, channelMsgInfo :: Maybe ChannelMsgInfo} | JCInfoLocal {noteFolder :: NoteFolder} | JCInfoContactRequest {contactRequest :: UserContactRequest} | JCInfoContactConnection {contactConnection :: PendingContactConnection} @@ -206,6 +227,8 @@ data JSONChatInfo $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GCSI") ''GroupChatScopeInfo) +$(JQ.deriveJSON defaultJSON ''ChannelMsgInfo) + $(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) instance FromJSON JSONChatInfo where @@ -224,7 +247,7 @@ instance ToJSON (ChatInfo c) where jsonChatInfo :: ChatInfo c -> JSONChatInfo jsonChatInfo = \case DirectChat c -> JCInfoDirect c - GroupChat g s -> JCInfoGroup g s + GroupChat g s cm -> JCInfoGroup g s cm LocalChat l -> JCInfoLocal l ContactRequest g -> JCInfoContactRequest g ContactConnection c -> JCInfoContactConnection c @@ -237,7 +260,7 @@ deriving instance Show AChatInfo jsonAChatInfo :: JSONChatInfo -> AChatInfo jsonAChatInfo = \case JCInfoDirect c -> AChatInfo SCTDirect $ DirectChat c - JCInfoGroup g s -> AChatInfo SCTGroup $ GroupChat g s + JCInfoGroup g s cm -> AChatInfo SCTGroup $ GroupChat g s cm JCInfoLocal l -> AChatInfo SCTLocal $ LocalChat l JCInfoContactRequest g -> AChatInfo SCTContactRequest $ ContactRequest g JCInfoContactConnection c -> AChatInfo SCTContactConnection $ ContactConnection c @@ -406,9 +429,9 @@ toChatInfo :: ChatDirection c d -> ChatInfo c toChatInfo = \case CDDirectSnd c -> DirectChat c CDDirectRcv c -> DirectChat c - CDGroupSnd g s -> GroupChat g s - CDGroupRcv g s _ -> GroupChat g s - CDChannelRcv g s -> GroupChat g s + CDGroupSnd g s -> GroupChat g s Nothing + CDGroupRcv g s _ -> GroupChat g s Nothing + CDChannelRcv g s -> GroupChat g s Nothing CDLocalSnd l -> LocalChat l CDLocalRcv l -> LocalChat l @@ -513,6 +536,12 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta forwardedByMember :: Maybe GroupMemberId, showGroupAsSender :: ShowGroupAsSender, msgSigned :: Maybe MsgSigStatus, + -- Set on a comment row; references the parent channel post. + parentChatItemId :: Maybe ChatItemId, + -- Set on a parent channel post; running total of non-deleted comments. + commentsTotal :: Int, + -- Set on a parent channel post; True locks the post against new comments. + commentsDisabled :: Bool, createdAt :: UTCTime, updatedAt :: UTCTime } @@ -520,12 +549,12 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta type ShowGroupAsSender = Bool -mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> Maybe MsgSigStatus -> UTCTime -> UTCTime -> CIMeta c d -mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt = +mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> Maybe MsgSigStatus -> Maybe ChatItemId -> Int -> Bool -> UTCTime -> UTCTime -> CIMeta c d +mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt = let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs editable = deletable && isNothing itemForwarded hasLink = BoolDef hasLink_ - in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgSigned, createdAt, updatedAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgSigned, parentChatItemId, commentsTotal, commentsDisabled, createdAt, updatedAt} deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool deletable' itemContent itemDeleted itemTs allowedInterval currentTs = @@ -557,6 +586,9 @@ dummyMeta itemId ts itemText = forwardedByMember = Nothing, showGroupAsSender = False, msgSigned = Nothing, + parentChatItemId = Nothing, + commentsTotal = 0, + commentsDisabled = False, createdAt = ts, updatedAt = ts } diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 6d7a094430..d7381ead13 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -82,12 +82,13 @@ import Simplex.Messaging.Version hiding (version) -- 15 - support specifying message scopes for group messages (2025-03-12) -- 16 - support short link data (2025-06-10) -- 17 - allow host voice messages during member approval regardless of group voice setting (2026-02-10) +-- 18 - support comments on channel posts (2026-04-07) -- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig. -- This indirection is needed for backward/forward compatibility testing. -- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code. currentChatVersion :: VersionChat -currentChatVersion = VersionChat 17 +currentChatVersion = VersionChat 18 -- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above) supportedChatVRange :: VersionRangeChat @@ -154,6 +155,10 @@ shortLinkDataVersion = VersionChat 16 memberSupportVoiceVersion :: VersionChat memberSupportVoiceVersion = VersionChat 17 +-- support comments on channel posts (merged MsgContainer with optional `parent`, XGrpCommentsDisabled) +commentsVersion :: VersionChat +commentsVersion = VersionChat 18 + agentToChatVersion :: VersionSMPA -> VersionChat agentToChatVersion v | v < pqdrSMPAgentVersion = initialChatVersion @@ -451,6 +456,8 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpDel :: ChatMsgEvent 'Json XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json + -- Governance: lock/unlock commenting on a specific channel post, addressed by its SharedMsgId. + XGrpCommentsDisabled :: {parentMsgId :: SharedMsgId, disabled :: Bool} -> ChatMsgEvent 'Json XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json XGrpMsgForward :: GrpMsgForward -> ChatMessage 'Json -> ChatMsgEvent 'Json XInfoProbe :: Probe -> ChatMsgEvent 'Json @@ -631,24 +638,58 @@ instance FromField MsgContentTag where fromField = fromTextField_ $ eitherToMayb instance ToField MsgContentTag where toField = toField . safeDecodeUtf8 . strEncode -data MsgContainer - = MCSimple ExtMsgContent - | MCQuote QuotedMsg ExtMsgContent - | MCComment MsgRef ExtMsgContent - | MCForward ExtMsgContent +-- Wire JSON 1:1 with parsed form. The three discriminator fields `quote`, `parent`, +-- and `forward` are independent and may co-occur (e.g. a comment that quotes another +-- comment carries both `parent` and `quote`). `forward` is a plain Bool (not Maybe Bool) +-- to match the existing wire format exactly: the serializer only emits `"forward": true` +-- and the parser treats absent/false as "not a forward". +data MsgContainer = MsgContainer + { content :: MsgContent, + -- the key used in mentions is a locally (per message) unique display name of member. + -- Suffixes _1, _2 should be appended to make names locally unique. + -- It should be done in the UI, as they will be part of the text, and validated in the API. + mentions :: Map MemberName MsgMention, + file :: Maybe FileInvitation, + ttl :: Maybe Int, + live :: Maybe Bool, + scope :: Maybe MsgScope, + asGroup :: Maybe Bool, + quote :: Maybe QuotedMsg, + parent :: Maybe MsgRef, + forward :: Bool + } deriving (Eq, Show) -mcExtMsgContent :: MsgContainer -> ExtMsgContent -mcExtMsgContent = \case - MCSimple c -> c - MCQuote _ c -> c - MCComment _ c -> c - MCForward c -> c +-- Base value used by the smart constructors and for record-update on send sites. +mc :: MsgContainer +mc = + MsgContainer + { content = MCText "", + mentions = M.empty, + file = Nothing, + ttl = Nothing, + live = Nothing, + scope = Nothing, + asGroup = Nothing, + quote = Nothing, + parent = Nothing, + forward = False + } + +mcSimple :: MsgContent -> MsgContainer +mcSimple c = mc {content = c} + +mcQuote :: QuotedMsg -> MsgContent -> MsgContainer +mcQuote q c = mc {content = c, quote = Just q} + +mcComment :: MsgRef -> MsgContent -> MsgContainer +mcComment p c = mc {content = c, parent = Just p} + +mcForward :: MsgContent -> MsgContainer +mcForward c = mc {content = c, forward = True} isMCForward :: MsgContainer -> Bool -isMCForward = \case - MCForward _ -> True - _ -> False +isMCForward MsgContainer {forward} = forward data MsgContent = MCText {text :: Text} @@ -722,20 +763,6 @@ msgContentTag = \case MCChat {} -> MCChat_ MCUnknown {tag} -> MCUnknown_ tag -data ExtMsgContent = ExtMsgContent - { content :: MsgContent, - -- the key used in mentions is a locally (per message) unique display name of member. - -- Suffixes _1, _2 should be appended to make names locally unique. - -- It should be done in the UI, as they will be part of the text, and validated in the API. - mentions :: Map MemberName MsgMention, - file :: Maybe FileInvitation, - ttl :: Maybe Int, - live :: Maybe Bool, - scope :: Maybe MsgScope, - asGroup :: Maybe Bool - } - deriving (Eq, Show) - data MsgMention = MsgMention {memberId :: MemberId} deriving (Eq, Show) @@ -851,9 +878,6 @@ parseMsgContainer v = asGroup <- v .:? "asGroup" pure ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} -extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent -extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing Nothing Nothing - justTrue :: Bool -> Maybe Bool justTrue True = Just True justTrue False = Nothing @@ -980,6 +1004,7 @@ data CMEventTag (e :: MsgEncoding) where XGrpDel_ :: CMEventTag 'Json XGrpInfo_ :: CMEventTag 'Json XGrpPrefs_ :: CMEventTag 'Json + XGrpCommentsDisabled_ :: CMEventTag 'Json XGrpDirectInv_ :: CMEventTag 'Json XGrpMsgForward_ :: CMEventTag 'Json XInfoProbe_ :: CMEventTag 'Json @@ -1037,6 +1062,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where XGrpDel_ -> "x.grp.del" XGrpInfo_ -> "x.grp.info" XGrpPrefs_ -> "x.grp.prefs" + XGrpCommentsDisabled_ -> "x.grp.cmnts.dsbl" XGrpDirectInv_ -> "x.grp.direct.inv" XGrpMsgForward_ -> "x.grp.msg.forward" XInfoProbe_ -> "x.info.probe" @@ -1095,6 +1121,7 @@ instance StrEncoding ACMEventTag where "x.grp.del" -> XGrpDel_ "x.grp.info" -> XGrpInfo_ "x.grp.prefs" -> XGrpPrefs_ + "x.grp.cmnts.dsbl" -> XGrpCommentsDisabled_ "x.grp.direct.inv" -> XGrpDirectInv_ "x.grp.msg.forward" -> XGrpMsgForward_ "x.info.probe" -> XInfoProbe_ @@ -1149,6 +1176,7 @@ toCMEventTag msg = case msg of XGrpDel -> XGrpDel_ XGrpInfo _ -> XGrpInfo_ XGrpPrefs _ -> XGrpPrefs_ + XGrpCommentsDisabled {} -> XGrpCommentsDisabled_ XGrpDirectInv {} -> XGrpDirectInv_ XGrpMsgForward {} -> XGrpMsgForward_ XInfoProbe _ -> XInfoProbe_ diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 06efcdc17a..a9dc835c98 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -28,6 +28,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260108_chat_indices import Simplex.Chat.Store.Postgres.Migrations.M20260122_has_link import Simplex.Chat.Store.Postgres.Migrations.M20260222_chat_relays import Simplex.Chat.Store.Postgres.Migrations.M20260403_item_viewed +import Simplex.Chat.Store.Postgres.Migrations.M20260407_channel_comments import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -55,7 +56,8 @@ schemaMigrations = ("20260108_chat_indices", m20260108_chat_indices, Just down_m20260108_chat_indices), ("20260122_has_link", m20260122_has_link, Just down_m20260122_has_link), ("20260222_chat_relays", m20260222_chat_relays, Just down_m20260222_chat_relays), - ("20260403_item_viewed", m20260403_item_viewed, Just down_m20260403_item_viewed) + ("20260403_item_viewed", m20260403_item_viewed, Just down_m20260403_item_viewed), + ("20260407_channel_comments", m20260407_channel_comments, Just down_m20260407_channel_comments) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260407_channel_comments.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260407_channel_comments.hs new file mode 100644 index 0000000000..93ffd400f3 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260407_channel_comments.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260407_channel_comments where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260407_channel_comments :: Text +m20260407_channel_comments = + [r| +ALTER TABLE chat_items ADD COLUMN parent_chat_item_id BIGINT REFERENCES chat_items ON DELETE CASCADE; +ALTER TABLE chat_items ADD COLUMN comments_total INTEGER NOT NULL DEFAULT 0; +ALTER TABLE chat_items ADD COLUMN comments_disabled SMALLINT NOT NULL DEFAULT 0; + +CREATE INDEX idx_chat_items_parent_chat_item_id ON chat_items(parent_chat_item_id); +CREATE INDEX idx_chat_items_parent_item_ts ON chat_items(user_id, group_id, parent_chat_item_id, item_ts); +|] + +down_m20260407_channel_comments :: Text +down_m20260407_channel_comments = + [r| +DROP INDEX idx_chat_items_parent_chat_item_id; +DROP INDEX idx_chat_items_parent_item_ts; +ALTER TABLE chat_items DROP COLUMN parent_chat_item_id; +ALTER TABLE chat_items DROP COLUMN comments_total; +ALTER TABLE chat_items DROP COLUMN comments_disabled; + +UPDATE group_members SET member_role = 'observer' WHERE member_role = 'commenter'; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 607e0549b1..0a332e4357 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -151,6 +151,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260108_chat_indices import Simplex.Chat.Store.SQLite.Migrations.M20260122_has_link import Simplex.Chat.Store.SQLite.Migrations.M20260222_chat_relays import Simplex.Chat.Store.SQLite.Migrations.M20260403_item_viewed +import Simplex.Chat.Store.SQLite.Migrations.M20260407_channel_comments import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -301,7 +302,8 @@ schemaMigrations = ("20260108_chat_indices", m20260108_chat_indices, Just down_m20260108_chat_indices), ("20260122_has_link", m20260122_has_link, Just down_m20260122_has_link), ("20260222_chat_relays", m20260222_chat_relays, Just down_m20260222_chat_relays), - ("20260403_item_viewed", m20260403_item_viewed, Just down_m20260403_item_viewed) + ("20260403_item_viewed", m20260403_item_viewed, Just down_m20260403_item_viewed), + ("20260407_channel_comments", m20260407_channel_comments, Just down_m20260407_channel_comments) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260407_channel_comments.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260407_channel_comments.hs new file mode 100644 index 0000000000..eb22f5ee70 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260407_channel_comments.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260407_channel_comments where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20260407_channel_comments :: Query +m20260407_channel_comments = + [sql| +ALTER TABLE chat_items ADD COLUMN parent_chat_item_id INTEGER REFERENCES chat_items ON DELETE CASCADE; +ALTER TABLE chat_items ADD COLUMN comments_total INTEGER NOT NULL DEFAULT 0; +ALTER TABLE chat_items ADD COLUMN comments_disabled INTEGER NOT NULL DEFAULT 0; + +CREATE INDEX idx_chat_items_parent_chat_item_id ON chat_items(parent_chat_item_id); +CREATE INDEX idx_chat_items_parent_item_ts ON chat_items(user_id, group_id, parent_chat_item_id, item_ts); +|] + +down_m20260407_channel_comments :: Query +down_m20260407_channel_comments = + [sql| +DROP INDEX idx_chat_items_parent_chat_item_id; +DROP INDEX idx_chat_items_parent_item_ts; +ALTER TABLE chat_items DROP COLUMN parent_chat_item_id; +ALTER TABLE chat_items DROP COLUMN comments_total; +ALTER TABLE chat_items DROP COLUMN comments_disabled; + +UPDATE group_members SET member_role = 'observer' WHERE member_role = 'commenter'; +|] diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index d8c6f10b3a..dd3365fab5 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -177,6 +177,7 @@ data GroupFeature | GFReports | GFHistory | GFSessions + | GFComments deriving (Show) data SGroupFeature (f :: GroupFeature) where @@ -190,6 +191,7 @@ data SGroupFeature (f :: GroupFeature) where SGFReports :: SGroupFeature 'GFReports SGFHistory :: SGroupFeature 'GFHistory SGFSessions :: SGroupFeature 'GFSessions + SGFComments :: SGroupFeature 'GFComments deriving instance Show (SGroupFeature f) @@ -217,6 +219,7 @@ groupFeatureNameText = \case GFReports -> "Member reports" GFHistory -> "Recent history" GFSessions -> "Chat sessions" + GFComments -> "Comments" groupFeatureNameText' :: SGroupFeature f -> Text groupFeatureNameText' = groupFeatureNameText . toGroupFeature @@ -240,11 +243,12 @@ allGroupFeatures = AGF SGFFiles, AGF SGFSimplexLinks, AGF SGFReports, - AGF SGFHistory + AGF SGFHistory, + AGF SGFComments ] groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) -groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, sessions} = case f of +groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, sessions, comments} = case f of SGFTimedMessages -> timedMessages SGFDirectMessages -> directMessages SGFFullDelete -> fullDelete @@ -255,6 +259,7 @@ groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reac SGFReports -> reports SGFHistory -> history SGFSessions -> sessions + SGFComments -> comments toGroupFeature :: SGroupFeature f -> GroupFeature toGroupFeature = \case @@ -268,6 +273,7 @@ toGroupFeature = \case SGFReports -> GFReports SGFHistory -> GFHistory SGFSessions -> GFSessions + SGFComments -> GFComments class GroupPreferenceI p where getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f @@ -279,7 +285,7 @@ instance GroupPreferenceI (Maybe GroupPreferences) where getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs) instance GroupPreferenceI FullGroupPreferences where - getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, sessions} = case f of + getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, sessions, comments} = case f of SGFTimedMessages -> timedMessages SGFDirectMessages -> directMessages SGFFullDelete -> fullDelete @@ -290,6 +296,7 @@ instance GroupPreferenceI FullGroupPreferences where SGFReports -> reports SGFHistory -> history SGFSessions -> sessions + SGFComments -> comments {-# INLINE getGroupPreference #-} -- collection of optional group preferences @@ -304,6 +311,7 @@ data GroupPreferences = GroupPreferences reports :: Maybe ReportsGroupPreference, history :: Maybe HistoryGroupPreference, sessions :: Maybe SessionsGroupPreference, + comments :: Maybe CommentsGroupPreference, commands :: Maybe [ChatBotCommand] } deriving (Eq, Show) @@ -354,6 +362,7 @@ setGroupPreference_ f pref prefs = SGFReports -> prefs {reports = pref} SGFHistory -> prefs {history = pref} SGFSessions -> prefs {sessions = pref} + SGFComments -> prefs {comments = pref} setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences setGroupTimedMessagesPreference pref prefs_ = @@ -396,6 +405,7 @@ data FullGroupPreferences = FullGroupPreferences reports :: ReportsGroupPreference, history :: HistoryGroupPreference, sessions :: SessionsGroupPreference, + comments :: CommentsGroupPreference, commands :: ListDef ChatBotCommand } deriving (Eq, Show) @@ -465,11 +475,12 @@ defaultGroupPrefs = reports = ReportsGroupPreference {enable = FEOn}, history = HistoryGroupPreference {enable = FEOff}, sessions = SessionsGroupPreference {enable = FEOff, role = Nothing}, + comments = CommentsGroupPreference {enable = FEOff, closeAfter = Nothing}, commands = ListDef [] } emptyGroupPrefs :: GroupPreferences -emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing businessGroupPrefs :: Preferences -> GroupPreferences businessGroupPrefs Preferences {timedMessages, fullDelete, reactions, voice, files, sessions, commands} = @@ -501,6 +512,7 @@ defaultBusinessGroupPrefs = reports = Just $ ReportsGroupPreference FEOff, history = Just $ HistoryGroupPreference FEOn, sessions = Just $ SessionsGroupPreference FEOn Nothing, + comments = Just $ CommentsGroupPreference FEOff Nothing, commands = Nothing } @@ -635,6 +647,14 @@ data SessionsGroupPreference = SessionsGroupPreference {enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole} deriving (Eq, Show) +-- Channel comments. `closeAfter` is the duration in seconds since post creation +-- after which a channel post stops accepting new comments; `Nothing` means never close. +data CommentsGroupPreference = CommentsGroupPreference + { enable :: GroupFeatureEnabled, + closeAfter :: Maybe Int + } + deriving (Eq, Show) + class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where type GroupFeaturePreference (f :: GroupFeature) = p | p -> f sGroupFeature :: SGroupFeature f @@ -678,6 +698,9 @@ instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where instance HasField "enable" SessionsGroupPreference GroupFeatureEnabled where hasField p@SessionsGroupPreference {enable} = (\e -> p {enable = e}, enable) +instance HasField "enable" CommentsGroupPreference GroupFeatureEnabled where + hasField p@CommentsGroupPreference {enable} = (\e -> p {enable = e}, enable) + instance GroupFeatureI 'GFTimedMessages where type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference sGroupFeature = SGFTimedMessages @@ -738,6 +761,12 @@ instance GroupFeatureI 'GFSessions where groupPrefParam _ = Nothing groupPrefRole SessionsGroupPreference {role} = role +instance GroupFeatureI 'GFComments where + type GroupFeaturePreference 'GFComments = CommentsGroupPreference + sGroupFeature = SGFComments + groupPrefParam CommentsGroupPreference {closeAfter} = closeAfter + groupPrefRole _ = Nothing + instance GroupFeatureNoRoleI 'GFTimedMessages instance GroupFeatureNoRoleI 'GFFullDelete @@ -748,6 +777,8 @@ instance GroupFeatureNoRoleI 'GFReports instance GroupFeatureNoRoleI 'GFHistory +instance GroupFeatureNoRoleI 'GFComments + instance HasField "role" DirectMessagesGroupPreference (Maybe GroupMemberRole) where hasField p@DirectMessagesGroupPreference {role} = (\r -> p {role = r}, role) @@ -788,6 +819,7 @@ groupPrefStateText feature pref param role = groupParamText_ :: GroupFeature -> Maybe Int -> Text groupParamText_ feature param = case feature of GFTimedMessages -> maybe "" (\p -> " (" <> timedTTLText p <> ")") param + GFComments -> maybe "" (\p -> " (close after " <> timedTTLText p <> ")") param _ -> "" groupPreferenceText :: forall f. GroupFeatureI f => GroupFeaturePreference f -> Text @@ -938,6 +970,7 @@ mergeGroupPreferences groupPreferences = reports = pref SGFReports, history = pref SGFHistory, sessions = pref SGFSessions, + comments = pref SGFComments, commands = ListDef $ fromMaybe [] $ groupPreferences >>= commands_ } where @@ -957,6 +990,7 @@ toGroupPreferences groupPreferences@FullGroupPreferences {commands = ListDef cmd reports = pref SGFReports, history = pref SGFHistory, sessions = pref SGFSessions, + comments = pref SGFComments, commands = Just cmds } where @@ -1091,6 +1125,12 @@ instance FromJSON SessionsGroupPreference where parseJSON v = $(J.mkParseJSON defaultJSON ''SessionsGroupPreference) v omittedField = Just SessionsGroupPreference {enable = FEOff, role = Nothing} +$(J.deriveToJSON defaultJSON ''CommentsGroupPreference) + +instance FromJSON CommentsGroupPreference where + parseJSON v = $(J.mkParseJSON defaultJSON ''CommentsGroupPreference) v + omittedField = Just CommentsGroupPreference {enable = FEOff, closeAfter = Nothing} + $(J.deriveJSON defaultJSON ''GroupPreferences) instance ToField GroupPreferences where diff --git a/src/Simplex/Chat/Types/Shared.hs b/src/Simplex/Chat/Types/Shared.hs index 22cb73f325..57abd3092c 100644 --- a/src/Simplex/Chat/Types/Shared.hs +++ b/src/Simplex/Chat/Types/Shared.hs @@ -19,6 +19,7 @@ data GroupMemberRole = GRUnknown Text -- unknown role from a newer client | GRRelay -- chat relay: forwards messages, can't send its own messages | GRObserver -- connects to all group members and receives all messages, can't send messages + | GRCommenter -- + can comment on channel posts, can't send messages to the main channel | GRAuthor -- reserved, unused | GRMember -- + can send messages to all group members | GRModerator -- + moderate messages and block members (excl. Admins and Owners) @@ -37,6 +38,7 @@ instance TextEncoding GroupMemberRole where GRModerator -> "moderator" GRMember -> "member" GRAuthor -> "author" + GRCommenter -> "commenter" GRObserver -> "observer" GRRelay -> "relay" GRUnknown t -> t @@ -46,6 +48,7 @@ instance TextEncoding GroupMemberRole where "moderator" -> GRModerator "member" -> GRMember "author" -> GRAuthor + "commenter" -> GRCommenter "observer" -> GRObserver "relay" -> GRRelay t -> GRUnknown t