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>
2026-05-24 23:55:50 +00:00 · 2025-01-08 09:42:26 +00:00
parent 05a5d161fb
commit 569832c8de
17 changed files with 519 additions and 458 deletions
@@ -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
@@ -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 =
@@ -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 ()
@@ -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
@@ -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;
 |]
@@ -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;
+|]
@@ -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
+);
@@ -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
@@ -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
@@ -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]"]