IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: full deletion by sender based on preference; don't overwrite item content on "mark deleted" (#1470)

Browse Source
This commit is contained in:
JRoberts 2022-11-30 19:42:33 +04:00 committed by GitHub
parent 6f24281671
commit 9ad29aa17e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 288 additions and 229 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
packages/simplex-chat-client/typescript/src/response.ts
View File

@ -266,7 +266,8 @@ export interface CRChatItemUpdated extends CR {
export interface CRChatItemDeleted extends CR {
type: "chatItemDeleted"
deletedChatItem: AChatItem
toChatItem: AChatItem
toChatItem?: AChatItem
byUser: boolean
}
export interface CRMsgIntegrityError extends CR {

1
simplex-chat.cabal
View File

@ -64,6 +64,7 @@ library
Simplex.Chat.Migrations.M20221112_server_password
Simplex.Chat.Migrations.M20221115_server_cfg
Simplex.Chat.Migrations.M20221129_delete_group_feature_items
Simplex.Chat.Migrations.M20221130_delete_item_deleted
Simplex.Chat.Mobile
Simplex.Chat.Options
Simplex.Chat.ProfileGenerator

125
src/Simplex/Chat.hs
View File

@ -291,9 +291,9 @@ processChatCommand = \case
CTDirect -> do
ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
case featureProhibited forUser ct mc of
Just f -> pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText f)
_ -> do
if isVoice mc && not (featureAllowed CFVoice forUser ct)
then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice)
else do
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_
(msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer)
@ -340,9 +340,9 @@ processChatCommand = \case
CTGroup -> do
Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
case groupFeatureProhibited gInfo mc of
Just f -> pure $ chatCmdError $ "feature not allowed " <> T.unpack (groupFeatureToText f)
_ -> do
if isVoice mc && not (groupFeatureAllowed GFVoice gInfo)
then pure $ chatCmdError $ "feature not allowed " <> T.unpack (groupFeatureToText GFVoice)
else do
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length ms)
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_ membership
msg@SndMessage {sharedMsgId} <- sendGroupMessage gInfo ms (XMsgNew msgContainer)
@ -444,44 +444,31 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError "not supported"
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user@User {userId} -> withChatLock "deleteChatItem" $ case cType of
CTDirect -> do
(ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
(ct@Contact {localDisplayName = c}, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
case (mode, msgDir, itemSharedMsgId) of
(CIDMInternal, _, _) -> do
deleteCIFile user file
toCi <- withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMInternal
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi
(CIDMInternal, _, _) -> deleteDirectCI user ct ci True
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
void $ sendDirectContactMessage ct (XMsgDel itemSharedMId)
deleteCIFile user file
toCi <- withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMBroadcast
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId)
setActive $ ActiveC c
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi
if featureAllowed CFFullDelete forUser ct
then deleteDirectCI user ct ci True
else markDirectCIDeleted user ct ci msgId True
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
-- TODO for group integrity and pending messages, group items and messages are set to "deleted"; maybe a different workaround is needed
CTGroup -> do
Group gInfo@GroupInfo {localDisplayName = gName, membership} ms <- withStore $ \db -> getGroup db user chatId
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file} <- withStore $ \db -> getGroupChatItem db user chatId itemId
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId) of
(CIDMInternal, _, _) -> do
deleteCIFile user file
toCi <- withStore $ \db -> deleteGroupChatItemLocal db user gInfo itemId CIDMInternal
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi
(CIDMInternal, _, _) -> deleteGroupCI user gInfo ci True
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
void $ sendGroupMessage gInfo ms (XMsgDel itemSharedMId)
deleteCIFile user file
toCi <- withStore $ \db -> deleteGroupChatItemLocal db user gInfo itemId CIDMBroadcast
SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId)
setActive $ ActiveG gName
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi
if groupFeatureAllowed GFFullDelete gInfo
then deleteGroupCI user gInfo ci True
else markGroupCIDeleted user gInfo ci msgId True
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
CTContactRequest -> pure $ chatCmdError "not supported"
CTContactConnection -> pure $ chatCmdError "not supported"
where
deleteCIFile :: MsgDirectionI d => User -> Maybe (CIFile d) -> m ()
deleteCIFile user file =
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
deleteFile user fileInfo
APIChatRead (ChatRef cType chatId) fromToIds -> case cType of
CTDirect -> withStore' (\db -> updateDirectChatItemsRead db chatId fromToIds) $> CRCmdOk
CTGroup -> withStore' (\db -> updateGroupChatItemsRead db chatId fromToIds) $> CRCmdOk
@ -2213,9 +2200,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
let ExtMsgContent content fileInvitation_ = mcExtMsgContent mc
case featureProhibited forContact ct content of
Just f -> void $ newChatItem (CIRcvChatFeatureRejected f) Nothing
_ -> do
if isVoice content && not (featureAllowed CFVoice forContact ct)
then void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing
else do
ciFile_ <- processFileInvitation fileInvitation_ content $ \db -> createRcvFileTransfer db userId ct
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_
when (enableNtfs chatSettings) $ showMsgToast (c <> "> ") content formattedText
@ -2268,19 +2255,20 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
_ -> throwError e
where
deleteRcvChatItem = do
CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId
ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId
case msgDir of
SMDRcv -> do
toCi <- withStore $ \db -> deleteDirectChatItemRcvBroadcast db userId ct itemId msgId
toView $ CRChatItemDeleted (AChatItem SCTDirect SMDRcv (DirectChat ct) deletedItem) toCi
SMDRcv ->
if featureAllowed CFFullDelete forContact ct
then deleteDirectCI user ct ci False >>= toView
else markDirectCIDeleted user ct ci msgId False >>= toView
SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete"
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
newGroupContentMessage gInfo@GroupInfo {chatSettings} m@GroupMember {localDisplayName = c} mc msg msgMeta = do
let (ExtMsgContent content fInv_) = mcExtMsgContent mc
case groupFeatureProhibited gInfo content of
Just f -> void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing
_ -> do
if isVoice content && not (groupFeatureAllowed GFVoice gInfo)
then void $ newChatItem (CIRcvGroupFeatureRejected GFVoice) Nothing
else do
ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_
let g = groupName' gInfo
@ -2319,13 +2307,14 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> RcvMessage -> m ()
groupMessageDelete gInfo@GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId RcvMessage {msgId} = do
CChatItem msgDir deletedItem@ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
ci@(CChatItem msgDir ChatItem {chatDir}) <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
case (msgDir, chatDir) of
(SMDRcv, CIGroupRcv m) ->
if sameMemberId memberId m
then do
toCi <- withStore $ \db -> deleteGroupChatItemRcvBroadcast db user gInfo itemId msgId
toView $ CRChatItemDeleted (AChatItem SCTGroup SMDRcv (GroupChat gInfo) deletedItem) toCi
then
if groupFeatureAllowed GFFullDelete gInfo
then deleteGroupCI user gInfo ci False >>= toView
else markGroupCIDeleted user gInfo ci msgId False >>= toView
else messageError "x.msg.del: group member attempted to delete a message of another member" -- shouldn't happen now that query includes group member id
(SMDSnd, _) -> messageError "x.msg.del: group member attempted invalid message delete"
@ -3067,6 +3056,34 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTs currentTs = do
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId False False tz currentTs itemTs currentTs currentTs
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, file}
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> m ChatResponse
deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser = do
deleteCIFile user file
withStore' $ \db -> deleteDirectChatItem db user ct ci
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> m ChatResponse
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser = do
deleteCIFile user file
withStore' $ \db -> deleteGroupChatItem db user gInfo ci
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) Nothing byUser
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
deleteCIFile user file =
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
deleteFile user fileInfo
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> m ChatResponse
markDirectCIDeleted user ct ci@(CChatItem msgDir deletedItem) msgId byUser = do
toCi <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) (Just toCi) byUser
markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> m ChatResponse
markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser = do
toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) (Just toCi) byUser
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
createAgentConnectionAsync user cmdFunction enableNtfs cMode = do
cmdId <- withStore' $ \db -> createCommand db user Nothing cmdFunction
@ -3125,21 +3142,6 @@ createGroupFeatureChangedItems user cd ciContent p p' =
sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing}
featureProhibited :: (PrefEnabled -> Bool) -> Contact -> MsgContent -> Maybe ChatFeature
featureProhibited forWhom Contact {mergedPreferences} = \case
MCVoice {} ->
let ContactUserPreference {enabled} =
getContactUserPreference CFVoice mergedPreferences
in if forWhom enabled then Nothing else Just CFVoice
_ -> Nothing
groupFeatureProhibited :: GroupInfo -> MsgContent -> Maybe GroupFeature
groupFeatureProhibited GroupInfo {fullGroupPreferences} = \case
MCVoice {} ->
let GroupPreference {enable} = getGroupPreference GFVoice fullGroupPreferences
in case enable of FEOn -> Nothing; FEOff -> Just GFVoice
_ -> Nothing
createInternalChatItem :: forall c d m. (ChatTypeI c, MsgDirectionI d, ChatMonad m) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> m ()
createInternalChatItem user cd content itemTs_ = do
createdAt <- liftIO getCurrentTime
@ -3403,6 +3405,9 @@ chatCommandP =
"/voice #" *> (SetGroupFeature GFVoice <$> displayName <*> (A.space *> strP)),
"/voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)),
"/voice " *> (SetUserFeature CFVoice <$> strP),
"/full_delete #" *> (SetGroupFeature GFFullDelete <$> displayName <*> (A.space *> strP)),
"/full_delete @" *> (SetContactFeature CFFullDelete <$> displayName <*> optional (A.space *> strP)),
"/full_delete " *> (SetUserFeature CFFullDelete <$> strP),
"/dms #" *> (SetGroupFeature GFDirectMessages <$> displayName <*> (A.space *> strP)),
"/incognito " *> (SetIncognito <$> onOffP),
("/quit" <|> "/q" <|> "/exit") $> QuitChat,

2
src/Simplex/Chat/Controller.hs
View File

@ -279,7 +279,7 @@ data ChatResponse
| CRNewChatItem {chatItem :: AChatItem}
| CRChatItemStatusUpdated {chatItem :: AChatItem}
| CRChatItemUpdated {chatItem :: AChatItem}
| CRChatItemDeleted {deletedChatItem :: AChatItem, toChatItem :: AChatItem}
| CRChatItemDeleted {deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool}
| CRChatItemDeletedNotFound {contact :: Contact, sharedMsgId :: SharedMsgId}
| CRBroadcastSent MsgContent Int ZonedTime
| CRMsgIntegrityError {msgError :: MsgErrorType}

4
src/Simplex/Chat/Messages.hs
View File

@ -547,8 +547,8 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
data CIContent (d :: MsgDirection) where
CISndMsgContent :: MsgContent -> CIContent 'MDSnd
CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv
CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd
CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv
CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd -- legacy - since v4.3.0 item_deleted field is used
CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv -- legacy - since v4.3.0 item_deleted field is used
CISndCall :: CICallStatus -> Int -> CIContent 'MDSnd
CIRcvCall :: CICallStatus -> Int -> CIContent 'MDRcv
CIRcvIntegrityError :: MsgErrorType -> CIContent 'MDRcv

2
src/Simplex/Chat/Migrations/M20220122_v1_1.hs
View File

@ -33,7 +33,7 @@ CREATE TABLE chat_items (
created_by_msg_id INTEGER UNIQUE REFERENCES messages (message_id) ON DELETE SET NULL,
item_sent INTEGER NOT NULL, -- 0 for received, 1 for sent
item_ts TEXT NOT NULL, -- broker_ts of creating message for received, created_at for sent
item_deleted INTEGER NOT NULL DEFAULT 0, -- 1 for deleted, -- ! legacy field that was used for group chat items when they weren't fully deleted
item_deleted INTEGER NOT NULL DEFAULT 0, -- 1 for deleted
item_content TEXT NOT NULL, -- JSON
item_text TEXT NOT NULL, -- textual representation
created_at TEXT NOT NULL DEFAULT (datetime('now')),

12
src/Simplex/Chat/Migrations/M20221130_delete_item_deleted.hs Normal file
View File

@ -0,0 +1,12 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20221130_delete_item_deleted where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20221130_delete_item_deleted :: Query
m20221130_delete_item_deleted =
[sql|
DELETE FROM chat_items WHERE item_deleted = 1; -- clean up legacy not fully deleted group chat items
|]

4
src/Simplex/Chat/Migrations/chat_schema.sql
View File

@ -349,8 +349,8 @@ CREATE TABLE chat_items(
created_by_msg_id INTEGER UNIQUE REFERENCES messages(message_id) ON DELETE SET NULL,
item_sent INTEGER NOT NULL, -- 0 for received, 1 for sent
item_ts TEXT NOT NULL, -- broker_ts of creating message for received, created_at for sent
item_deleted INTEGER NOT NULL DEFAULT 0, -- 1 for deleted, -- ! legacy field that was used for group chat items when they weren't fully deleted
item_content TEXT NOT NULL, -- JSON
item_deleted INTEGER NOT NULL DEFAULT 0, -- 1 for deleted
item_content TEXT NOT NULL, -- JSON
item_text TEXT NOT NULL, -- textual representation
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))

154
src/Simplex/Chat/Store.hs
View File

@ -195,11 +195,11 @@ module Simplex.Chat.Store
updateDirectChatItemStatus,
updateDirectCIFileStatus,
updateDirectChatItem,
deleteDirectChatItemLocal,
deleteDirectChatItemRcvBroadcast,
deleteDirectChatItem,
markDirectChatItemDeleted,
updateGroupChatItem,
deleteGroupChatItemLocal,
deleteGroupChatItemRcvBroadcast,
deleteGroupChatItem,
markGroupChatItemDeleted,
updateDirectChatItemsRead,
updateGroupChatItemsRead,
getSMPServers,
@ -299,6 +299,7 @@ import Simplex.Chat.Migrations.M20221029_group_link_id
import Simplex.Chat.Migrations.M20221112_server_password
import Simplex.Chat.Migrations.M20221115_server_cfg
import Simplex.Chat.Migrations.M20221129_delete_group_feature_items
import Simplex.Chat.Migrations.M20221130_delete_item_deleted
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@ -348,7 +349,8 @@ schemaMigrations =
("20221029_group_link_id", m20221029_group_link_id),
("20221112_server_password", m20221112_server_password),
("20221115_server_cfg", m20221115_server_cfg),
("20221129_delete_group_feature_items", m20221129_delete_group_feature_items)
("20221129_delete_group_feature_items", m20221129_delete_group_feature_items),
("20221130_delete_item_deleted", m20221130_delete_item_deleted)
]
-- | The list of migrations in ascending order by date
@ -3244,7 +3246,6 @@ getDirectChatPreviews_ db user@User {userId} = do
LEFT JOIN (
SELECT contact_id, MAX(chat_item_id) AS MaxId
FROM chat_items
WHERE item_deleted != 1
GROUP BY contact_id
) MaxIds ON MaxIds.contact_id = ct.contact_id
LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id
@ -3253,7 +3254,7 @@ getDirectChatPreviews_ db user@User {userId} = do
LEFT JOIN (
SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
FROM chat_items
WHERE item_status = ? AND item_deleted != 1
WHERE item_status = ?
GROUP BY contact_id
) ChatStats ON ChatStats.contact_id = ct.contact_id
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.contact_id = i.contact_id
@ -3319,7 +3320,6 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
LEFT JOIN (
SELECT group_id, MAX(chat_item_id) AS MaxId
FROM chat_items
WHERE item_deleted != 1
GROUP BY group_id
) MaxIds ON MaxIds.group_id = g.group_id
LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id
@ -3328,7 +3328,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
LEFT JOIN (
SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
FROM chat_items
WHERE item_status = ? AND item_deleted != 1
WHERE item_status = ?
GROUP BY group_id
) ChatStats ON ChatStats.group_id = g.group_id
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
@ -3467,7 +3467,7 @@ getDirectChatLast_ db user@User {userId} contactId count search = do
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.contact_id = i.contact_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_deleted != 1 AND i.item_text LIKE '%' || ? || '%'
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%'
ORDER BY i.chat_item_id DESC
LIMIT ?
|]
@ -3498,7 +3498,7 @@ getDirectChatAfter_ db user@User {userId} contactId afterChatItemId count search
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.contact_id = i.contact_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_deleted != 1 AND i.item_text LIKE '%' || ? || '%'
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%'
AND i.chat_item_id > ?
ORDER BY i.chat_item_id ASC
LIMIT ?
@ -3530,7 +3530,7 @@ getDirectChatBefore_ db user@User {userId} contactId beforeChatItemId count sear
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.contact_id = i.contact_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_deleted != 1 AND i.item_text LIKE '%' || ? || '%'
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%'
AND i.chat_item_id < ?
ORDER BY i.chat_item_id DESC
LIMIT ?
@ -3596,7 +3596,7 @@ getGroupChatLast_ db user@User {userId} groupId count search = do
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_deleted != 1 AND item_text LIKE '%' || ? || '%'
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
@ -3619,7 +3619,7 @@ getGroupChatAfter_ db user@User {userId} groupId afterChatItemId count search =
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_deleted != 1 AND item_text LIKE '%' || ? || '%'
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
ORDER BY item_ts ASC, chat_item_id ASC
LIMIT ?
@ -3643,7 +3643,7 @@ getGroupChatBefore_ db user@User {userId} groupId beforeChatItemId count search
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_deleted != 1 AND item_text LIKE '%' || ? || '%'
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
@ -3791,24 +3791,17 @@ updateDirectChatItem_ db userId contactId itemId newContent currentTs = do
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
deleteDirectChatItemLocal :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteDirectChatItemLocal db userId ct itemId mode = do
liftIO $ deleteChatItemMessages_ db itemId
deleteDirectChatItem_ db userId ct itemId mode
deleteDirectChatItem_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteDirectChatItem_ db userId ct@Contact {contactId} itemId mode = do
(CChatItem msgDir ci) <- getDirectChatItem db userId contactId itemId
let toContent = msgDirToDeletedContent_ msgDir mode
liftIO $ do
DB.execute
db
[sql|
DELETE FROM chat_items
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|]
(userId, contactId, itemId)
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {content = toContent, meta = (meta ci) {itemText = ciDeleteModeToText mode, itemDeleted = True}, formattedText = Nothing})
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
DB.execute
db
[sql|
DELETE FROM chat_items
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|]
(userId, contactId, itemId)
deleteChatItemMessages_ :: DB.Connection -> ChatItemId -> IO ()
deleteChatItemMessages_ db itemId =
@ -3824,27 +3817,20 @@ deleteChatItemMessages_ db itemId =
|]
(Only itemId)
deleteDirectChatItemRcvBroadcast :: DB.Connection -> UserId -> Contact -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem
deleteDirectChatItemRcvBroadcast db userId ct itemId msgId = do
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> IO AChatItem
markDirectChatItemDeleted db User {userId} ct@Contact {contactId} (CChatItem msgDir ci) msgId = do
currentTs <- liftIO getCurrentTime
liftIO $ insertChatItemMessage_ db itemId msgId currentTs
updateDirectChatItemRcvDeleted_ db userId ct itemId currentTs
updateDirectChatItemRcvDeleted_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> UTCTime -> ExceptT StoreError IO AChatItem
updateDirectChatItemRcvDeleted_ db userId ct@Contact {contactId} itemId currentTs = do
(CChatItem msgDir ci) <- getDirectChatItem db userId contactId itemId
let toContent = msgDirToDeletedContent_ msgDir CIDMBroadcast
toText = ciDeleteModeToText CIDMBroadcast
liftIO $ do
DB.execute
db
[sql|
UPDATE chat_items
SET item_content = ?, item_text = ?, updated_at = ?
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|]
(toContent, toText, currentTs, userId, contactId, itemId)
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {content = toContent, meta = (meta ci) {itemText = toText}, formattedText = Nothing})
let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs
DB.execute
db
[sql|
UPDATE chat_items
SET item_deleted = 1, updated_at = ?
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|]
(currentTs, userId, contactId, itemId)
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {meta = (meta ci) {itemDeleted = True}})
getDirectChatItemBySharedMsgId :: DB.Connection -> UserId -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId db userId contactId sharedMsgId = do
@ -3928,46 +3914,32 @@ updateGroupChatItem db user@User {userId} groupId itemId newContent msgId = do
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
deleteGroupChatItemLocal :: DB.Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteGroupChatItemLocal db user gInfo itemId mode = do
liftIO $ deleteChatItemMessages_ db itemId
deleteGroupChatItem_ db user gInfo itemId mode
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO ()
deleteGroupChatItem db User {userId} GroupInfo {groupId} (CChatItem _ ci) = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
DB.execute
db
[sql|
DELETE FROM chat_items
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(userId, groupId, itemId)
deleteGroupChatItem_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteGroupChatItem_ db user@User {userId} gInfo@GroupInfo {groupId} itemId mode = do
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
let toContent = msgDirToDeletedContent_ msgDir mode
liftIO $ do
DB.execute
db
[sql|
DELETE FROM chat_items
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = ciDeleteModeToText mode, itemDeleted = True}, formattedText = Nothing})
deleteGroupChatItemRcvBroadcast :: DB.Connection -> User -> GroupInfo -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem
deleteGroupChatItemRcvBroadcast db user gInfo itemId msgId = do
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> IO AChatItem
markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId = do
currentTs <- liftIO getCurrentTime
liftIO $ insertChatItemMessage_ db itemId msgId currentTs
updateGroupChatItemRcvDeleted_ db user gInfo itemId currentTs
updateGroupChatItemRcvDeleted_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> UTCTime -> ExceptT StoreError IO AChatItem
updateGroupChatItemRcvDeleted_ db user@User {userId} gInfo@GroupInfo {groupId} itemId currentTs = do
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
let toContent = msgDirToDeletedContent_ msgDir CIDMBroadcast
toText = ciDeleteModeToText CIDMBroadcast
liftIO $ do
DB.execute
db
[sql|
UPDATE chat_items
SET item_content = ?, item_text = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(toContent, toText, currentTs, userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText}, formattedText = Nothing})
let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs
DB.execute
db
[sql|
UPDATE chat_items
SET item_deleted = 1, updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(currentTs, userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = True}})
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do

10
src/Simplex/Chat/Types.hs
View File

@ -261,6 +261,11 @@ chatFeatureToText = \case
CFFullDelete -> "Full deletion"
CFVoice -> "Voice messages"
featureAllowed :: ChatFeature -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed feature forWhom Contact {mergedPreferences} =
let ContactUserPreference {enabled} = getContactUserPreference feature mergedPreferences
in forWhom enabled
instance ToJSON ChatFeature where
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CF"
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CF"
@ -336,6 +341,11 @@ groupFeatureToText = \case
GFFullDelete -> "Full deletion"
GFVoice -> "Voice messages"
groupFeatureAllowed :: GroupFeature -> GroupInfo -> Bool
groupFeatureAllowed feature GroupInfo {fullGroupPreferences} =
let GroupPreference {enable} = getGroupPreference feature fullGroupPreferences
in enable == FEOn
instance ToJSON GroupFeature where
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF"
toJSON = J.genericToJSON . enumJSON $ dropPrefix "GF"

116
src/Simplex/Chat/View.hs
View File

@ -78,7 +78,7 @@ responseToView user_ testView ts = \case
CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts) chatItems
CRChatItemStatusUpdated _ -> []
CRChatItemUpdated (AChatItem _ _ chat item) -> unmuted chat item $ viewItemUpdate chat item ts
CRChatItemDeleted (AChatItem _ _ chat deletedItem) (AChatItem _ _ _ toItem) -> unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem ts
CRChatItemDeleted (AChatItem _ _ chat deletedItem) toItem byUser -> unmuted chat deletedItem $ viewItemDelete chat deletedItem (isJust toItem) byUser ts
CRChatItemDeletedNotFound Contact {localDisplayName = c} _ -> [ttyFrom $ c <> "> [deleted - original message not found]"]
CRBroadcastSent mc n t -> viewSentBroadcast mc n ts t
CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr
@ -223,14 +223,14 @@ responseToView user_ testView ts = \case
toChatView (AChat _ (Chat (ContactRequest UserContactRequest {localDisplayName}) items _)) = ("<@" <> localDisplayName, toCIPreview items, Nothing)
toChatView (AChat _ (Chat (ContactConnection PendingContactConnection {pccConnId, pccConnStatus}) items _)) = (":" <> T.pack (show pccConnId), toCIPreview items, Just pccConnStatus)
toCIPreview :: [CChatItem c] -> Text
toCIPreview ((CChatItem _ ChatItem {meta}) : _) = itemText meta
toCIPreview (ci : _) = testViewItem ci
toCIPreview _ = ""
testViewChat :: AChat -> [StyledString]
testViewChat (AChat _ Chat {chatItems}) = [sShow $ map toChatView chatItems]
where
toChatView :: CChatItem c -> ((Int, Text), Maybe (Int, Text), Maybe String)
toChatView (CChatItem dir ChatItem {meta, quotedItem, file}) =
((msgDirectionInt $ toMsgDirection dir, itemText meta), qItem, fPath)
toChatView ci@(CChatItem dir ChatItem {quotedItem, file}) =
((msgDirectionInt $ toMsgDirection dir, testViewItem ci), qItem, fPath)
where
qItem = case quotedItem of
Nothing -> Nothing
@ -239,6 +239,8 @@ responseToView user_ testView ts = \case
fPath = case file of
Just CIFile {filePath = Just fp} -> Just fp
_ -> Nothing
testViewItem :: CChatItem c -> Text
testViewItem (CChatItem _ ChatItem {meta = CIMeta {itemText, itemDeleted}}) = itemText <> if itemDeleted then " [marked deleted]" else ""
viewErrorsSummary :: [a] -> StyledString -> [StyledString]
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
contactList :: [ContactRef] -> String
@ -262,41 +264,43 @@ viewHostEvent :: AProtocolType -> TransportHost -> String
viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> [StyledString]
viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow ts = case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
CISndGroupEvent {} -> showSndItemProhibited to
_ -> showSndItem to
viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, quotedItem, file} doShow ts =
withItemDeleted <$> case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
CISndGroupEvent {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToContact' c
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromContact' c
where
to = ttyToContact' c
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromGroup' g m
where
from = ttyFromContact' c
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromGroup' g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> []
quote = maybe [] (groupQuote g) quotedItem
_ -> []
where
withItemDeleted item = if itemDeleted then item <> styled (colored Red) (" [marked deleted]" :: String) else item
withSndFile = withFile viewSentFileInvitation
withRcvFile = withFile viewReceivedFileInvitation
withFile view dir l = maybe l (\f -> l <> view dir f ts meta) file
@ -312,7 +316,7 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow ts
showRcvItemProhibited from = showItem $ receivedWithTime_ ts from [] meta [plainContent content <> " " <> prohibited]
showItem ss = if doShow then ss else []
plainContent = plain . ciContentToText
prohibited = styled (colored Red) ("[prohibited - it's a bug if this chat item was created in this context, please report it to dev team]" :: String)
prohibited = styled (colored Red) ("[unexpected chat item created, please report to developers]" :: String)
viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> CurrentTime -> [StyledString]
viewItemUpdate chat ChatItem {chatDir, meta, content, quotedItem} ts = case chat of
@ -334,19 +338,19 @@ viewItemUpdate chat ChatItem {chatDir, meta, content, quotedItem} ts = case chat
CIGroupSnd -> ["message updated"]
_ -> []
viewItemDelete :: ChatInfo c -> ChatItem c d -> ChatItem c' d' -> CurrentTime -> [StyledString]
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} ChatItem {content = toContent} ts = case chat of
DirectChat Contact {localDisplayName = c} -> case (chatDir, deletedContent, toContent) of
(CIDirectRcv, CIRcvMsgContent mc, CIRcvDeleted mode) -> case mode of
CIDMBroadcast -> viewReceivedMessage (ttyFromContactDeleted c) [] mc ts meta
CIDMInternal -> ["message deleted"]
_ -> ["message deleted"]
GroupChat g -> case (chatDir, deletedContent, toContent) of
(CIGroupRcv GroupMember {localDisplayName = m}, CIRcvMsgContent mc, CIRcvDeleted mode) -> case mode of
CIDMBroadcast -> viewReceivedMessage (ttyFromGroupDeleted g m) [] mc ts meta
CIDMInternal -> ["message deleted"]
_ -> ["message deleted"]
_ -> []
viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> CurrentTime -> [StyledString]
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser ts
| byUser = if markedDeleted then ["message marked deleted"] else ["message deleted"]
| otherwise = case chat of
DirectChat Contact {localDisplayName = c} -> case (chatDir, deletedContent) of
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c markedDeleted) [] mc ts meta
_ -> prohibited
GroupChat g -> case (chatDir, deletedContent) of
(CIGroupRcv GroupMember {localDisplayName = m}, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m markedDeleted) [] mc ts meta
_ -> prohibited
_ -> prohibited
where
prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)]
directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString]
directQuote _ CIQuote {content = qmc, chatDir = quoteDir} =
@ -1164,8 +1168,10 @@ ttyFromContact c = ttyFrom $ c <> "> "
ttyFromContactEdited :: ContactName -> StyledString
ttyFromContactEdited c = ttyFrom $ c <> "> [edited] "
ttyFromContactDeleted :: ContactName -> StyledString
ttyFromContactDeleted c = ttyFrom $ c <> "> [deleted] "
ttyFromContactDeleted :: ContactName -> Bool -> StyledString
ttyFromContactDeleted c markedDeleted
| markedDeleted = ttyFrom $ c <> "> [marked deleted] "
| otherwise = ttyFrom $ c <> "> [deleted] "
ttyToContact' :: Contact -> StyledString
ttyToContact' Contact {localDisplayName = c, activeConn = Connection {customUserProfileId}} =
@ -1203,8 +1209,10 @@ ttyFromGroup GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c
ttyFromGroupEdited :: GroupInfo -> ContactName -> StyledString
ttyFromGroupEdited GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> [edited] "
ttyFromGroupDeleted :: GroupInfo -> ContactName -> StyledString
ttyFromGroupDeleted GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> [deleted] "
ttyFromGroupDeleted :: GroupInfo -> ContactName -> Bool -> StyledString
ttyFromGroupDeleted GroupInfo {localDisplayName = g} c markedDeleted
| markedDeleted = ttyFrom $ "#" <> g <> " " <> c <> "> [marked deleted] "
| otherwise = ttyFrom $ "#" <> g <> " " <> c <> "> [deleted] "
ttyFrom :: Text -> StyledString
ttyFrom = styled $ colored Yellow

84
tests/ChatTests.hs
View File

@ -122,6 +122,8 @@ chatTests = do
describe "preferences" $ do
it "set contact preferences" testSetContactPrefs
it "update group preferences" testUpdateGroupPrefs
it "allow full deletion to contact" testAllowFullDeletionContact
it "allow full deletion to group" testAllowFullDeletionGroup
describe "SMP servers" $ do
it "get and set SMP servers" testGetSetSMPServers
it "test SMP server connection" testTestSMPServerConnection
@ -399,18 +401,19 @@ testDirectMessageDelete =
alice @@@ [("@bob", "hey alice")]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hey alice")])
-- bob: deletes msg id 2
bob #$> ("/_delete item @2 " <> itemId 2 <> " broadcast", id, "message deleted")
alice <# "bob> [deleted] hey alice"
alice @@@ [("@bob", "this item is deleted (broadcast)")]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "this item is deleted (broadcast)")])
-- bob: marks deleted msg id 2
bob #$> ("/_delete item @2 " <> itemId 2 <> " broadcast", id, "message marked deleted")
bob @@@ [("@alice", "hey alice [marked deleted]")]
alice <# "bob> [marked deleted] hey alice"
alice @@@ [("@bob", "hey alice [marked deleted]")]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hey alice [marked deleted]")])
-- alice: deletes msg id 1 that was broadcast deleted by bob
alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted")
alice @@@ [("@bob", "Voice messages: enabled")]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1, bob: msg id 2 (quoting message alice deleted locally)
-- alice: msg id 1, bob: msg id 3 (quoting message alice deleted locally)
bob `send` "> @alice (hello 🙂) do you receive my messages?"
bob <# "@alice > hello 🙂"
bob <## " do you receive my messages?"
@ -420,20 +423,25 @@ testDirectMessageDelete =
alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "do you receive my messages?"), Just (1, "hello 🙂"))])
alice #$> ("/_delete item @2 " <> itemId 1 <> " broadcast", id, "cannot delete this item")
-- alice: msg id 2, bob: msg id 3
-- alice: msg id 2, bob: msg id 4
bob #> "@alice how are you?"
alice <# "bob> how are you?"
-- alice: deletes msg id 2
alice #$> ("/_delete item @2 " <> itemId 2 <> " internal", id, "message deleted")
-- bob: deletes msg id 3 (that alice deleted locally)
bob #$> ("/_delete item @2 " <> itemId 3 <> " broadcast", id, "message deleted")
-- bob: marks deleted msg id 4 (that alice deleted locally)
bob #$> ("/_delete item @2 " <> itemId 4 <> " broadcast", id, "message marked deleted")
alice <## "bob> [deleted - original message not found]"
alice @@@ [("@bob", "do you receive my messages?")]
alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "do you receive my messages?"), Just (1, "hello 🙂"))])
bob @@@ [("@alice", "do you receive my messages?")]
bob @@@ [("@alice", "how are you? [marked deleted]")]
bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "hello 🙂"), Nothing), ((1, "hey alice [marked deleted]"), Just (0, "hello 🙂")), ((1, "do you receive my messages?"), Just (0, "hello 🙂")), ((1, "how are you? [marked deleted]"), Nothing)])
-- bob: deletes msg ids 2,4 (that he has marked deleted)
bob #$> ("/_delete item @2 " <> itemId 2 <> " internal", id, "message deleted")
bob #$> ("/_delete item @2 " <> itemId 4 <> " internal", id, "message deleted")
bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "hello 🙂"), Nothing), ((1, "do you receive my messages?"), Just (0, "hello 🙂"))])
testGroup :: Spec
@ -1285,17 +1293,17 @@ testGroupMessageDelete =
(alice <# "#team cath> how are you?")
(bob <# "#team cath> how are you?")
cath #$> ("/_delete item #1 " <> groupItemId 2 7 <> " broadcast", id, "message deleted")
cath #$> ("/_delete item #1 " <> groupItemId 2 7 <> " broadcast", id, "message marked deleted")
concurrently_
(alice <# "#team cath> [deleted] how are you?")
(bob <# "#team cath> [deleted] how are you?")
(alice <# "#team cath> [marked deleted] how are you?")
(bob <# "#team cath> [marked deleted] how are you?")
alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "cannot delete this item")
alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted")
alice #$> ("/_get chat #1 count=1", chat', [((0, "this item is deleted (broadcast)"), Nothing)])
bob #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "this item is deleted (broadcast)"), Nothing)])
cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alice"), Just (0, "hello!"))])
alice #$> ("/_get chat #1 count=1", chat', [((0, "how are you? [marked deleted]"), Nothing)])
bob #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "how are you? [marked deleted]"), Nothing)])
cath #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((0, "hi alice"), Just (0, "hello!")), ((1, "how are you? [marked deleted]"), Nothing)])
testUpdateGroupProfile :: IO ()
testUpdateGroupProfile =
@ -3108,6 +3116,48 @@ testUpdateGroupPrefs =
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on"), (1, "hey"), (0, "hi")])
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on"), (0, "hey"), (1, "hi")])
testAllowFullDeletionContact :: IO ()
testAllowFullDeletionContact =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
alice <##> bob
alice ##> "/full_delete @bob always"
alice <## "you updated preferences for bob:"
alice <## "Full deletion: enabled for contact (you allow: always, contact allows: no)"
bob <## "alice updated preferences for you:"
bob <## "Full deletion: enabled for you (you allow: default (no), contact allows: always)"
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi"), (0, "hey"), (1, "Full deletion: enabled for contact")])
bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hi"), (1, "hey"), (0, "Full deletion: enabled for you")])
bob #$> ("/_delete item @2 " <> itemId 2 <> " broadcast", id, "message deleted")
alice <# "bob> [deleted] hey"
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi"), (1, "Full deletion: enabled for contact")])
bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hi"), (0, "Full deletion: enabled for you")])
testAllowFullDeletionGroup :: IO ()
testAllowFullDeletionGroup =
testChat2 aliceProfile bobProfile $
\alice bob -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team hi"
bob <# "#team alice> hi"
threadDelay 1000000
bob #> "#team hey"
alice <# "#team bob> hey"
alice ##> "/full_delete #team on"
alice <## "updated group preferences:"
alice <## "Full deletion enabled: on"
bob <## "alice updated group #team:"
bob <## "updated group preferences:"
bob <## "Full deletion enabled: on"
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (0, "hey"), (1, "Full deletion: on")])
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (1, "hey"), (0, "Full deletion: on")])
bob #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "message deleted")
alice <# "#team bob> [deleted] hey"
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (1, "Full deletion: on")])
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (0, "Full deletion: on")])
testGetSetSMPServers :: IO ()
testGetSetSMPServers =
testChat2 aliceProfile bobProfile $
@ -4249,7 +4299,7 @@ itemId :: Int -> String
itemId i = show $ length chatFeatures + i
groupItemId :: Int -> Int -> String
groupItemId n i = show $ (length chatFeatures) * n + i
groupItemId n i = show $ length chatFeatures * n + i
(@@@) :: TestCC -> [(String, String)] -> Expectation
(@@@) = getChats . map $ \(ldn, msg, _) -> (ldn, msg)