core: rfc, protocol and types for user reports (#5451)

* core: rfc, protocol and types for user reports

* add comment

* rfc

* moderation rfc

* api, types

* update

* typos

* migration

* update

* report reason

* query

* deleted

* remove auto-accepting conditions for SimpleX Chat Ltd

* api, query

* make indices work

* index without filtering

* query for unread

* postgres: rework chat list pagination query (#5441)

* fix query

* fix

* report counts to stats

* internalMark

* fix parser

* AND

* delete reports on event, fix counters

* test

* remove reports when message is moderated on sending side

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny 2025-01-08 09:42:26 +00:00 committed by GitHub
parent 05a5d161fb
commit 569832c8de
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
17 changed files with 519 additions and 458 deletions

View file

@ -3348,9 +3348,11 @@ public enum MREmojiChar: String, Codable, CaseIterable, Hashable {
case thumbsup = "👍"
case thumbsdown = "👎"
case smile = "😀"
case laugh = "😂"
case sad = "😢"
case heart = ""
case launch = "🚀"
case check = ""
}
extension MsgReaction: Decodable {

View file

@ -3202,9 +3202,11 @@ enum class MREmojiChar(val value: String) {
@SerialName("👍") ThumbsUp("👍"),
@SerialName("👎") ThumbsDown("👎"),
@SerialName("😀") Smile("😀"),
@SerialName("😂") Laugh("😂"),
@SerialName("😢") Sad("😢"),
@SerialName("") Heart(""),
@SerialName("🚀") Launch("🚀");
@SerialName("🚀") Launch("🚀"),
@SerialName("") Check("");
}
@Serializable

View file

@ -688,7 +688,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
sendComposedMessage cc ct Nothing $ MCText text
getContact :: ChatController -> ContactId -> IO (Maybe Contact)
getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) (CPLast 0) Nothing)
getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) Nothing (CPLast 0) Nothing)
where
resp :: ChatResponse -> Maybe Contact
resp = \case

View file

@ -113,6 +113,12 @@
"properties": {
"text": {"type": "string", "metadata": {"comment": "can be empty"}}
}
},
"report": {
"properties": {
"text": {"type": "string", "metadata": {"comment": "can be empty, includes report reason for old clients"}},
"reason": {"enum": ["spam", "illegal", "community", "other"]}
}
}
},
"metadata": {

View file

@ -162,6 +162,7 @@ library
Simplex.Chat.Migrations.M20241222_operator_conditions
Simplex.Chat.Migrations.M20241223_chat_tags
Simplex.Chat.Migrations.M20241230_reports
Simplex.Chat.Migrations.M20250105_indexes
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

View file

@ -297,7 +297,7 @@ data ChatCommand
| SlowSQLQueries
| APIGetChatTags UserId
| APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: PaginationByTime, query :: ChatListQuery}
| APIGetChat ChatRef ChatPagination (Maybe String)
| APIGetChat ChatRef (Maybe ContentFilter) ChatPagination (Maybe String)
| APIGetChatItems ChatPagination (Maybe String)
| APIGetChatItemInfo ChatRef ChatItemId
| APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
@ -635,6 +635,7 @@ data ChatResponse
| CRChatItemReaction {user :: User, added :: Bool, reaction :: ACIReaction}
| CRReactionMembers {user :: User, memberReactions :: [MemberReaction]}
| CRChatItemsDeleted {user :: User, chatItemDeletions :: [ChatItemDeletion], byUser :: Bool, timed :: Bool}
| CRGroupChatItemsDeleted {user :: User, groupInfo :: GroupInfo, chatItemIDs :: [ChatItemId], byUser :: Bool, member_ :: Maybe GroupMember}
| CRChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId}
| CRBroadcastSent {user :: User, msgContent :: MsgContent, successes :: Int, failures :: Int, timestamp :: UTCTime}
| CRMsgIntegrityError {user :: User, msgError :: MsgErrorType}
@ -867,6 +868,12 @@ logResponseToFile = \case
CRMessageError {} -> True
_ -> False
data ContentFilter = ContentFilter
{ mcTag :: MsgContentTag,
deleted :: Maybe Bool
}
deriving (Show)
data ChatPagination
= CPLast Int
| CPAfter ChatItemId Int

View file

@ -481,15 +481,17 @@ processChatCommand' vr = \case
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user pendingConnections pagination query)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
APIGetChat (ChatRef cType cId) contentFilter pagination search -> withUser $ \user -> case cType of
-- TODO optimize queries calculating ChatStats, currently they're disabled
CTDirect -> do
when (isJust contentFilter) $ throwChatError $ CECommandError "content filter not supported"
(directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat) navInfo
CTGroup -> do
(groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId pagination search)
(groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId contentFilter pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat) navInfo
CTLocal -> do
when (isJust contentFilter) $ throwChatError $ CECommandError "content filter not supported"
(localChat, navInfo) <- withFastStore (\db -> getLocalChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat) navInfo
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
@ -2158,14 +2160,14 @@ processChatCommand' vr = \case
pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
chatResp <- processChatCommand $ APIGetChat chatRef Nothing (CPLast count) search
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
LastMessages Nothing count search -> withUser $ \user -> do
chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast count) search
pure $ CRChatItems user Nothing chatItems
LastChatItemId (Just chatName) index -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
chatResp <- processChatCommand (APIGetChat chatRef Nothing (CPLast $ index + 1) Nothing)
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
LastChatItemId Nothing index -> withUser $ \user -> do
chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing
@ -2639,6 +2641,9 @@ processChatCommand' vr = \case
delGroupChatItems :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> CM ChatResponse
delGroupChatItems user gInfo items byGroupMember = do
deletedTs <- liftIO getCurrentTime
forM_ byGroupMember $ \byMember -> do
ciIds <- concat <$> withStore' (\db -> forM items $ \(CChatItem _ ci) -> markMessageReportsDeleted db user gInfo ci byMember deletedTs)
unless (null ciIds) $ toView $ CRGroupChatItemsDeleted user gInfo ciIds False (Just byMember)
if groupFeatureAllowed SGFFullDelete gInfo
then deleteGroupCIs user gInfo items True False byGroupMember deletedTs
else markGroupCIsDeleted user gInfo items True byGroupMember deletedTs
@ -3573,7 +3578,7 @@ chatCommandP =
<*> (A.space *> paginationByTimeP <|> pure (PTLast 5000))
<*> (A.space *> jsonP <|> pure clqNoFilters)
),
"/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)),
"/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> optional (contentFilterP <* A.space) <*> chatPaginationP <*> optional (" search=" *> stringP)),
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)),
"/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
"/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
@ -3948,6 +3953,7 @@ chatCommandP =
ct -> ChatName ct <$> displayName
chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName
chatRefP = ChatRef <$> chatTypeP <*> A.decimal
contentFilterP = ContentFilter <$> ("content=" *> strP) <*> optional (" deleted=" *> onOffP)
msgCountP = A.space *> A.decimal <|> pure 10
ciTTLDecimal = ("none" $> Nothing) <|> (Just <$> A.decimal)
ciTTL =

View file

@ -1840,7 +1840,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
moderate :: GroupMember -> CChatItem 'CTGroup -> CM ()
moderate mem cci = case sndMemberId_ of
Just sndMemberId
| sameMemberId sndMemberId mem -> checkRole mem $ delete cci (Just m) >>= toView
| sameMemberId sndMemberId mem -> checkRole mem $ do
delete cci (Just m) >>= toView
archiveMessageReports cci m
| otherwise -> messageError "x.msg.del: message of another member with incorrect memberId"
_ -> messageError "x.msg.del: message of another member without memberId"
checkRole GroupMember {memberRole} a
@ -1851,6 +1853,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
delete cci byGroupMember
| groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCIs user gInfo [cci] False False byGroupMember brokerTs
| otherwise = markGroupCIsDeleted user gInfo [cci] False byGroupMember brokerTs
archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM ()
archiveMessageReports (CChatItem _ ci) byMember = do
ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs
unless (null ciIds) $ toView $ CRGroupChatItemsDeleted user gInfo ciIds False (Just byMember)
-- TODO remove once XFile is discontinued
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM ()

View file

@ -91,14 +91,6 @@ chatInfoChatTs = \case
GroupChat GroupInfo {chatTs} -> chatTs
_ -> Nothing
chatInfoUpdatedAt :: ChatInfo c -> UTCTime
chatInfoUpdatedAt = \case
DirectChat Contact {updatedAt} -> updatedAt
GroupChat GroupInfo {updatedAt} -> updatedAt
LocalChat NoteFolder {updatedAt} -> updatedAt
ContactRequest UserContactRequest {updatedAt} -> updatedAt
ContactConnection PendingContactConnection {updatedAt} -> updatedAt
chatInfoToRef :: ChatInfo c -> ChatRef
chatInfoToRef = \case
DirectChat Contact {contactId} -> ChatRef CTDirect contactId
@ -318,12 +310,17 @@ data AChat = forall c. ChatTypeI c => AChat (SChatType c) (Chat c)
deriving instance Show AChat
data ChatStats = ChatStats
{ unreadCount :: Int,
{ unreadCount :: Int, -- returned both in /_get chat initial API and in /_get chats API
reportsCount :: Int, -- returned both in /_get chat initial API and in /_get chats API
archivedReportsCount :: Int, -- only returned in /_get chat initial API
minUnreadItemId :: ChatItemId,
unreadChat :: Bool
}
deriving (Show)
emptyChatStats :: ChatStats
emptyChatStats = ChatStats 0 0 0 0 False
data NavigationInfo = NavigationInfo
{ afterUnread :: Int,
afterTotal :: Int

View file

@ -1,18 +1,18 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20241230_reports where
module Simplex.Chat.Migrations.M20241230_reports where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20241230_reports :: Query
m20241230_reports =
[sql|
m20241230_reports :: Query
m20241230_reports =
[sql|
ALTER TABLE chat_items ADD COLUMN msg_content_tag TEXT;
|]
down_m20241230_reports :: Query
down_m20241230_reports =
[sql|
down_m20241230_reports :: Query
down_m20241230_reports =
[sql|
ALTER TABLE chat_items DROP COLUMN msg_content_tag;
|]

View file

@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20250105_indexes where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20250105_indexes :: Query
m20250105_indexes =
[sql|
CREATE INDEX idx_chat_items_groups_msg_content_tag_item_ts ON chat_items(user_id, group_id, msg_content_tag, item_ts);
CREATE INDEX idx_chat_items_groups_msg_content_tag_item_deleted_item_ts ON chat_items(user_id, group_id, msg_content_tag, item_deleted, item_ts);
|]
down_m20250105_indexes :: Query
down_m20250105_indexes =
[sql|
DROP INDEX idx_chat_items_groups_msg_content_tag_item_ts;
DROP INDEX idx_chat_items_groups_msg_content_tag_item_deleted_item_ts;
|]

View file

@ -962,3 +962,16 @@ CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_group_id ON chat_tags_chats(
group_id,
chat_tag_id
);
CREATE INDEX idx_chat_items_groups_msg_content_tag_item_ts ON chat_items(
user_id,
group_id,
msg_content_tag,
item_ts
);
CREATE INDEX idx_chat_items_groups_msg_content_tag_item_deleted_item_ts ON chat_items(
user_id,
group_id,
msg_content_tag,
item_deleted,
item_ts
);

View file

@ -70,7 +70,7 @@ import Simplex.Messaging.Version hiding (version)
-- 9 - batch sending in direct connections (2024-07-24)
-- 10 - business chats (2024-11-29)
-- 11 - fix profile update in business chats (2024-12-05)
-- 12 - fix profile update in business chats (2025-01-03)
-- 12 - support sending and receiving content reports (2025-01-03)
-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
-- This indirection is needed for backward/forward compatibility testing.
@ -443,7 +443,7 @@ instance FromJSON MREmojiChar where
mrEmojiChar :: Char -> Either String MREmojiChar
mrEmojiChar c
| c `elem` ("👍👎😀😢❤️🚀" :: String) = Right $ MREmojiChar c
| c `elem` ("👍👎😀😂😢❤️🚀" :: String) = Right $ MREmojiChar c
| otherwise = Left "bad emoji"
data FileChunk = FileChunk {chunkNo :: Integer, chunkBytes :: ByteString} | FileChunkCancel
@ -485,7 +485,7 @@ cmToQuotedMsg = \case
_ -> Nothing
data MsgContentTag = MCText_ | MCLink_ | MCImage_ | MCVideo_ | MCVoice_ | MCFile_ | MCReport_ | MCUnknown_ Text
deriving (Eq)
deriving (Eq, Show)
instance StrEncoding MsgContentTag where
strEncode = \case
@ -522,6 +522,7 @@ instance ToField MsgContentTag where toField = toField . strEncode
data MsgContainer
= MCSimple ExtMsgContent
| MCQuote QuotedMsg ExtMsgContent
| MCComment MsgRef ExtMsgContent
| MCForward ExtMsgContent
deriving (Eq, Show)
@ -529,13 +530,9 @@ mcExtMsgContent :: MsgContainer -> ExtMsgContent
mcExtMsgContent = \case
MCSimple c -> c
MCQuote _ c -> c
MCComment _ c -> c
MCForward c -> c
isQuote :: MsgContainer -> Bool
isQuote = \case
MCQuote {} -> True
_ -> False
data MsgContent
= MCText Text
| MCLink {text :: Text, preview :: LinkPreview}
@ -564,9 +561,6 @@ msgContentText = \case
msg = "report " <> safeDecodeUtf8 (strEncode reason)
MCUnknown {text} -> text
toMCText :: MsgContent -> MsgContent
toMCText = MCText . msgContentText
durationText :: Int -> Text
durationText duration =
let (mins, secs) = duration `divMod` 60 in T.pack $ "(" <> with0 mins <> ":" <> with0 secs <> ")"
@ -657,7 +651,10 @@ markCompressedBatch = B.cons 'X'
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
where
@ -708,6 +705,7 @@ 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
where

File diff suppressed because it is too large Load diff

View file

@ -122,6 +122,7 @@ import Simplex.Chat.Migrations.M20241205_business_chat_members
import Simplex.Chat.Migrations.M20241222_operator_conditions
import Simplex.Chat.Migrations.M20241223_chat_tags
import Simplex.Chat.Migrations.M20241230_reports
import Simplex.Chat.Migrations.M20250105_indexes
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -243,7 +244,8 @@ schemaMigrations =
("20241205_business_chat_members", m20241205_business_chat_members, Just down_m20241205_business_chat_members),
("20241222_operator_conditions", m20241222_operator_conditions, Just down_m20241222_operator_conditions),
("20241223_chat_tags", m20241223_chat_tags, Just down_m20241223_chat_tags),
("20241230_reports", m20241230_reports, Just down_m20241230_reports)
("20241230_reports", m20241230_reports, Just down_m20241230_reports),
("20250105_indexes", m20250105_indexes, Just down_m20250105_indexes)
]
-- | The list of migrations in ascending order by date

View file

@ -156,6 +156,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
[ChatItemDeletion (AChatItem _ _ chat deletedItem) toItem] ->
ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView
deletions' -> ttyUser u [sShow (length deletions') <> " messages deleted"]
CRGroupChatItemsDeleted u g ciIds byUser member_ -> ttyUser u [ttyGroup' g <> ": " <> sShow (length ciIds) <> " messages deleted by " <> if byUser then "user" else "member" <> maybe "" (\m -> " " <> ttyMember m) member_]
CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz
CRReactionMembers u memberReactions -> ttyUser u $ viewReactionMembers memberReactions
CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"]

View file

@ -6600,3 +6600,34 @@ testGroupMemberReports =
bob <## " report content",
(cath </)
]
alice #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content")])
alice #$> ("/_get chat #1 content=report deleted=off count=100", chat, [(0, "report content")])
alice #$> ("/_get chat #1 content=report deleted=on count=100", chat, [])
bob #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content")])
bob #$> ("/_get chat #1 content=report deleted=off count=100", chat, [(0, "report content")])
bob #$> ("/_get chat #1 content=report deleted=on count=100", chat, [])
dan #$> ("/_get chat #1 content=report count=100", chat, [(1, "report content")])
dan #$> ("/_get chat #1 content=report deleted=off count=100", chat, [(1, "report content")])
dan #$> ("/_get chat #1 content=report deleted=on count=100", chat, [])
alice ##> "\\\\ #jokes cath inappropriate joke"
concurrentlyN_
[ do
alice <## "#jokes: 1 messages deleted by member alice"
alice <## "message marked deleted by you",
do
bob <# "#jokes cath> [marked deleted by alice] inappropriate joke"
bob <## "#jokes: 1 messages deleted by member alice",
cath <# "#jokes cath> [marked deleted by alice] inappropriate joke",
do
dan <# "#jokes cath> [marked deleted by alice] inappropriate joke"
dan <## "#jokes: 1 messages deleted by member alice"
]
alice #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content [marked deleted by you]")])
alice #$> ("/_get chat #1 content=report deleted=off count=100", chat, [])
alice #$> ("/_get chat #1 content=report deleted=on count=100", chat, [(0, "report content [marked deleted by you]")])
bob #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content [marked deleted by alice]")])
bob #$> ("/_get chat #1 content=report deleted=off count=100", chat, [])
bob #$> ("/_get chat #1 content=report deleted=on count=100", chat, [(0, "report content [marked deleted by alice]")])
dan #$> ("/_get chat #1 content=report count=100", chat, [(1, "report content [marked deleted by alice]")])
dan #$> ("/_get chat #1 content=report deleted=off count=100", chat, [])
dan #$> ("/_get chat #1 content=report deleted=on count=100", chat, [(1, "report content [marked deleted by alice]")])