dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-08-27 22:34:51 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: api to delete multiple messages (#4452)

Browse Source 
* core: api proposal (not implemeted) to delete multiple messages

* core: batch delete multiple messages; allow to moderate self (#4513)

* allow to moderate self, remove saving item-message record on mark delete

* direct batched

* local batched

* group batched

* moderate batched

* refactor

* fix

* fix test

* remove unused event

* direct message batching wip

* direct test

* more tests

* trunk

* batch compressed

* remove unused function

* new agent api

* sendGroupMessages

* forward batched

* refactor

* remove comment

* rename, comment

* refactor

* many chat batches test (doesn't pass)

* refactor

* comment

* rename

* comment

* linearize

* fix

* fix

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

* core: check item deletable with margin (#4533)

* simplexmq

* remove L.singleton (ghc 8.10.7)

* test delay

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2024-07-30 22:59:47 +01:00
committed by GitHub
co-authored by spaced4ndy
parent ab058d7222
commit 8bda64a5c1
16 changed files with 685 additions and 323 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+433 -275
View File
File diff suppressed because it is too large Load Diff
src/Simplex/Chat/Bot.hs
+3 -2
View File
@@ -3,6 +3,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
module Simplex.Chat.Bot where
@@ -73,9 +74,9 @@ sendComposedMessage' cc ctId quotedItemId msgContent = do
deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
deleteMessage cc ct chatItemId = do
let cmd = APIDeleteChatItem (contactRef ct) chatItemId CIDMInternal
let cmd = APIDeleteChatItem (contactRef ct) [chatItemId] CIDMInternal
sendChatCmd cc cmd >>= \case
CRChatItemDeleted {} -> printLog cc CLLInfo $ "deleted message from " <> contactInfo ct
CRChatItemsDeleted {} -> printLog cc CLLInfo $ "deleted message(s) from " <> contactInfo ct
r -> putStrLn $ "unexpected delete message response: " <> show r
contactRef :: Contact -> ChatRef
src/Simplex/Chat/Controller.hs
+12 -4
View File
@@ -69,7 +69,7 @@ import Simplex.Chat.Types.UITheme
import Simplex.Chat.Util (liftIOEither)
import Simplex.FileTransfer.Description (FileDescriptionURI)
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, ServerQueueInfo, SMPServerSubs, UserNetworkInfo)
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
@@ -293,8 +293,8 @@ data ChatCommand
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage}
| APICreateChatItem {noteFolderId :: NoteFolderId, composedMessage :: ComposedMessage}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
| APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId
| APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode
| APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId)
| APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction}
| APIForwardChatItem {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemId :: ChatItemId, ttl :: Maybe Int}
| APIUserRead UserId
@@ -599,7 +599,7 @@ data ChatResponse
| CRChatItemUpdated {user :: User, chatItem :: AChatItem}
| CRChatItemNotChanged {user :: User, chatItem :: AChatItem}
| CRChatItemReaction {user :: User, added :: Bool, reaction :: ACIReaction}
| CRChatItemDeleted {user :: User, deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool, timed :: Bool}
| CRChatItemsDeleted {user :: User, chatItemDeletions :: [ChatItemDeletion], byUser :: Bool, timed :: Bool}
| CRChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId}
| CRBroadcastSent {user :: User, msgContent :: MsgContent, successes :: Int, failures :: Int, timestamp :: UTCTime}
| CRMsgIntegrityError {user :: User, msgError :: MsgErrorType}
@@ -1081,6 +1081,12 @@ tmeToPref currentTTL tme = uncurry TimedMessagesPreference $ case tme of
TMEEnableKeepTTL -> (FAYes, currentTTL)
TMEDisableKeepTTL -> (FANo, currentTTL)
data ChatItemDeletion = ChatItemDeletion
{ deletedChatItem :: AChatItem,
toChatItem :: Maybe AChatItem
}
deriving (Show)
data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant
deriving (Eq, Ord, Show)
@@ -1487,6 +1493,8 @@ $(JQ.deriveJSON defaultJSON ''ServerAddress)
$(JQ.deriveJSON defaultJSON ''ParsedServerAddress)
$(JQ.deriveJSON defaultJSON ''ChatItemDeletion)
$(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
$(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
src/Simplex/Chat/Messages.hs
+11 -7
View File
@@ -35,7 +35,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay)
import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay, NominalDiffTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Database.SQLite.Simple.FromField (FromField (..))
@@ -364,15 +364,19 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
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 -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt =
let deletable = case itemContent of
CISndMsgContent _ ->
case chatTypeI @c of
SCTLocal -> isNothing itemDeleted
_ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
_ -> False
let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs
editable = deletable && isNothing itemForwarded
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, deletable, editable, forwardedByMember, createdAt, updatedAt}
deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool
deletable' itemContent itemDeleted itemTs allowedInterval currentTs =
case itemContent of
CISndMsgContent _ ->
case chatTypeI @c of
SCTLocal -> isNothing itemDeleted
_ -> diffUTCTime currentTs itemTs < allowedInterval && isNothing itemDeleted
_ -> False
dummyMeta :: ChatItemId -> UTCTime -> Text -> CIMeta c 'MDSnd
dummyMeta itemId ts itemText =
CIMeta
src/Simplex/Chat/Protocol.hs
+23 -9
View File
@@ -31,8 +31,9 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
@@ -63,12 +64,14 @@ import Simplex.Messaging.Version hiding (version)
-- 5 - batch sending messages (12/23/2023)
-- 6 - send group welcome message after history (12/29/2023)
-- 7 - update member profiles (1/15/2024)
-- 8 - compress messages and PQ e2e encryption (2024-03-08)
-- 9 - batch sending in direct connections (2024-07-24)
-- 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 8
currentChatVersion = VersionChat 9
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRangeChat
@@ -103,6 +106,10 @@ memberProfileUpdateVersion = VersionChat 7
pqEncryptionCompressionVersion :: VersionChat
pqEncryptionCompressionVersion = VersionChat 8
-- version range that supports batch sending in direct connections, and forwarding batched messages in groups
batchSend2Version :: VersionChat
batchSend2Version = VersionChat 9
agentToChatVersion :: VersionSMPA -> VersionChat
agentToChatVersion v
| v < pqdrSMPAgentVersion = initialChatVersion
@@ -323,13 +330,20 @@ forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of
SJson | isForwardedGroupMsg chatMsgEvent -> Just msg
_ -> Nothing
-- applied after checking forwardedGroupMsg and building list of group members to forward to, see Chat
forwardedToGroupMembers :: forall e. MsgEncodingI e => [GroupMember] -> ChatMessage e -> [GroupMember]
forwardedToGroupMembers ms ChatMessage {chatMsgEvent} = case encoding @e of
SJson -> case chatMsgEvent of
XGrpMemRestrict mId _ -> filter (\GroupMember {memberId} -> memberId /= mId) ms
_ -> ms
_ -> []
-- applied after checking forwardedGroupMsg and building list of group members to forward to, see Chat;
-- this filters out members if any of forwarded events in batch is an XGrpMemRestrict event referring to them,
-- but practically XGrpMemRestrict is not batched with other events so it wouldn't prevent forwarding of other events
-- to these members
forwardedToGroupMembers :: forall e. MsgEncodingI e => [GroupMember] -> NonEmpty (ChatMessage e) -> [GroupMember]
forwardedToGroupMembers ms forwardedMsgs =
filter (\GroupMember {memberId} -> memberId `notElem` restrictMemberIds) ms
where
restrictMemberIds = mapMaybe restrictMemberId $ L.toList forwardedMsgs
restrictMemberId ChatMessage {chatMsgEvent} = case encoding @e of
SJson -> case chatMsgEvent of
XGrpMemRestrict mId _ -> Just mId
_ -> Nothing
_ -> Nothing
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
deriving (Eq, Show)
src/Simplex/Chat/Store/Messages.hs
+8 -10
View File
@@ -19,7 +19,7 @@ module Simplex.Chat.Store.Messages
-- * Message and chat item functions
deleteContactCIs,
getGroupFileInfo,
deleteGroupCIs,
deleteGroupChatItemsMessages,
createNewSndMessage,
createSndMsgDelivery,
createNewMessageAndRcvMsgDelivery,
@@ -170,8 +170,8 @@ getGroupFileInfo db User {userId} GroupInfo {groupId} =
map toFileInfo
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ?") (userId, groupId)
deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO ()
deleteGroupCIs db User {userId} GroupInfo {groupId} = do
deleteGroupChatItemsMessages :: DB.Connection -> User -> GroupInfo -> IO ()
deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do
DB.execute db "DELETE FROM messages WHERE group_id = ?" (Only groupId)
DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId)
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId)
@@ -1733,11 +1733,10 @@ deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO ()
deleteChatItemVersions_ db itemId =
DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId)
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> MessageId -> UTCTime -> IO (ChatItem 'CTDirect d)
markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} msgId deletedTs = do
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> UTCTime -> IO (ChatItem 'CTDirect d)
markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} deletedTs = do
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs
DB.execute
db
[sql|
@@ -1900,7 +1899,7 @@ 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}
pure ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing}
updateGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO (ChatItem 'CTGroup d)
updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = do
@@ -1931,14 +1930,13 @@ pattern DBCIBlocked = 2
pattern DBCIBlockedByAdmin :: Int
pattern DBCIBlockedByAdmin = 3
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} msgId byGroupMember_ deletedTs = do
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
(deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m)
_ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs))
insertChatItemMessage_ db itemId msgId currentTs
DB.execute
db
[sql|
src/Simplex/Chat/Terminal/Input.hs
+1 -1
View File
@@ -71,7 +71,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_
CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemDeleted u (AChatItem _ _ cInfo _) _ _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
src/Simplex/Chat/View.hs
+4 -1
View File
@@ -127,7 +127,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz
CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci
CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView
CRChatItemsDeleted u deletions byUser timed -> case deletions of
[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"]
CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz
CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"]
CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t