From 692f37daa26d26aaee27c08ae349e881c2ea383f Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Mon, 28 Mar 2022 20:35:57 +0400 Subject: [PATCH] core: message delete (#470) --- src/Simplex/Chat.hs | 110 ++++++++++++---- src/Simplex/Chat/Controller.hs | 12 +- src/Simplex/Chat/Messages.hs | 62 ++++++--- src/Simplex/Chat/Protocol.hs | 13 +- src/Simplex/Chat/Store.hs | 227 +++++++++++++++++++++++++-------- src/Simplex/Chat/View.hs | 46 +++++-- tests/ChatTests.hs | 157 +++++++++++++++++++++-- 7 files changed, 498 insertions(+), 129 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 458a34c46..fa0572a86 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -215,7 +215,7 @@ processChatCommand = \case msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} in sendNewGroupMsg user group (MCQuote QuotedMsg {msgRef, content} mc) mc (Just quotedItem) CTContactRequest -> pure $ chatCmdError "not supported" - APIUpdateMessage cType chatId itemId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of + APIUpdateChatItem cType chatId itemId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do (ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId case ci of @@ -226,8 +226,8 @@ processChatCommand = \case updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CISndMsgContent mc) msgId setActive $ ActiveC c pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi - _ -> throwChatError CEInvalidMessageUpdate - CChatItem SMDRcv _ -> throwChatError CEInvalidMessageUpdate + _ -> throwChatError CEInvalidChatItemUpdate + CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTGroup -> do Group gInfo@GroupInfo {groupId, localDisplayName = gName, membership} ms <- withStore $ \st -> getGroup st user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved @@ -240,12 +240,36 @@ processChatCommand = \case updCi <- withStore $ \st -> updateGroupChatItem st user groupId itemId (CISndMsgContent mc) msgId setActive $ ActiveG gName pure . CRChatItemUpdated $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) updCi - _ -> throwChatError CEInvalidMessageUpdate - CChatItem SMDRcv _ -> throwChatError CEInvalidMessageUpdate + _ -> throwChatError CEInvalidChatItemUpdate + CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTContactRequest -> pure $ chatCmdError "not supported" - APIDeleteMessage cType _chatId _itemId _mode -> withUser $ \_user -> withChatLock $ case cType of - CTDirect -> pure CRCmdOk - CTGroup -> pure CRCmdOk + APIDeleteChatItem cType chatId itemId mode -> withUser $ \user@User {userId} -> withChatLock $ case cType of + CTDirect -> do + (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId + case (mode, msgDir, itemSharedMsgId) of + (CIDMInternal, _, _) -> do + toCi <- withStore $ \st -> deleteDirectChatItemInternal st userId ct itemId + pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi + (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do + SndMessage {msgId} <- sendDirectContactMessage ct (XMsgDel itemSharedMId) + toCi <- withStore $ \st -> deleteDirectChatItemSndBroadcast st userId ct itemId msgId + setActive $ ActiveC c + pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi + (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete + CTGroup -> do + Group gInfo@GroupInfo {localDisplayName = gName, membership} ms <- withStore $ \st -> getGroup st user chatId + unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved + CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}} <- withStore $ \st -> getGroupChatItem st user chatId itemId + case (mode, msgDir, itemSharedMsgId) of + (CIDMInternal, _, _) -> do + toCi <- withStore $ \st -> deleteGroupChatItemInternal st user gInfo itemId + pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi + (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do + SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId) + toCi <- withStore $ \st -> deleteGroupChatItemSndBroadcast st user gInfo itemId msgId + setActive $ ActiveG gName + pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi + (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete CTContactRequest -> pure $ chatCmdError "not supported" APIChatRead cType chatId fromToIds -> withChatLock $ case cType of CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk @@ -717,6 +741,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage case chatMsgEvent of XMsgNew mc -> newContentMessage ct mc msg msgMeta XMsgUpdate sharedMsgId mContent -> messageUpdate ct sharedMsgId mContent msg msgMeta + XMsgDel sharedMsgId -> messageDelete ct sharedMsgId msg msgMeta XFile fInv -> processFileInvitation ct fInv msg msgMeta XInfo p -> xInfo ct p XGrpInv gInv -> processGroupInvitation ct gInv @@ -856,7 +881,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage withAckMessage agentConnId msgMeta $ case chatMsgEvent of XMsgNew mc -> newGroupContentMessage gInfo m mc msg msgMeta - XMsgUpdate sharedMsgId mContent -> groupMessageUpdate gInfo sharedMsgId mContent msg + XMsgUpdate sharedMsgId mContent -> groupMessageUpdate gInfo m sharedMsgId mContent msg + XMsgDel sharedMsgId -> groupMessageDelete gInfo m sharedMsgId msg XFile fInv -> processGroupFileInvitation gInfo m fInv msg msgMeta XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo XGrpMemIntro memInfo -> xGrpMemIntro conn gInfo m memInfo @@ -1036,11 +1062,28 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage setActive $ ActiveC c messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m () - messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc RcvMessage {msgId} msgMeta = do - updCi <- withStore $ \st -> updateDirectChatItemByMsgId st userId contactId sharedMsgId (CIRcvMsgContent mc) msgId - toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) updCi - checkIntegrity msgMeta $ toView . CRMsgIntegrityError - setActive $ ActiveC c + messageUpdate ct@Contact {contactId} sharedMsgId mc RcvMessage {msgId} msgMeta = do + CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId + case msgDir of + SMDRcv -> do + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CIRcvMsgContent mc) msgId + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) updCi + checkIntegrity msgMeta $ toView . CRMsgIntegrityError + SMDSnd -> do + messageError "x.msg.update: contact attempted invalid message update" + checkIntegrity msgMeta $ toView . CRMsgIntegrityError + + messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () + messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta = do + CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId + case msgDir of + SMDRcv -> do + toCi <- withStore $ \st -> deleteDirectChatItemRcvBroadcast st userId ct itemId msgId + toView $ CRChatItemDeleted (AChatItem SCTDirect SMDRcv (DirectChat ct) deletedItem) toCi + checkIntegrity msgMeta $ toView . CRMsgIntegrityError + SMDSnd -> do + messageError "x.msg.del: contact attempted invalid message delete" + checkIntegrity msgMeta $ toView . CRMsgIntegrityError newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m () newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do @@ -1051,12 +1094,29 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText setActive $ ActiveG g - groupMessageUpdate :: GroupInfo -> SharedMsgId -> MsgContent -> RcvMessage -> m () - groupMessageUpdate gInfo@GroupInfo {groupId} sharedMsgId mc RcvMessage {msgId} = do - updCi <- withStore $ \st -> updateGroupChatItemByMsgId st user groupId sharedMsgId (CIRcvMsgContent mc) msgId - toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) updCi - let g = groupName' gInfo - setActive $ ActiveG g + groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> m () + groupMessageUpdate gInfo@GroupInfo {groupId} GroupMember {memberId} sharedMsgId mc RcvMessage {msgId} = do + CChatItem msgDir ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \st -> getGroupChatItemBySharedMsgId st user groupId sharedMsgId + case (msgDir, chatDir) of + (SMDRcv, CIGroupRcv m) -> + if sameMemberId memberId m + then do + updCi <- withStore $ \st -> updateGroupChatItem st user groupId itemId (CIRcvMsgContent mc) msgId + toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) updCi + else messageError "x.msg.update: group member attempted to update a message of another member" + (SMDSnd, _) -> messageError "x.msg.update: group member attempted invalid message update" + + groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> RcvMessage -> m () + groupMessageDelete gInfo@GroupInfo {groupId} GroupMember {memberId} sharedMsgId RcvMessage {msgId} = do + CChatItem msgDir deletedItem@ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \st -> getGroupChatItemBySharedMsgId st user groupId sharedMsgId + case (msgDir, chatDir) of + (SMDRcv, CIGroupRcv m) -> + if sameMemberId memberId m + then do + toCi <- withStore $ \st -> deleteGroupChatItemRcvBroadcast st user gInfo itemId msgId + toView $ CRChatItemDeleted (AChatItem SCTGroup SMDRcv (GroupChat gInfo) deletedItem) toCi + else messageError "x.msg.del: group member attempted to delete a message of another member" + (SMDSnd, _) -> messageError "x.msg.del: group member attempted invalid message delete" processFileInvitation :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m () processFileInvitation ct@Contact {localDisplayName = c} fInv msg msgMeta = do @@ -1172,7 +1232,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage GCInviteeMember -> do members <- withStore $ \st -> getGroupMembers st user gInfo case find (sameMemberId memId) members of - Nothing -> messageError "x.grp.mem.inv error: referenced member does not exists" + Nothing -> messageError "x.grp.mem.inv error: referenced member does not exist" Just reMember -> do GroupMemberIntro {introId} <- withStore $ \st -> saveIntroInvitation st reMember m introInv void $ sendXGrpMemInv gInfo reMember (XGrpMemFwd (memberInfo m) introInv) introId @@ -1447,7 +1507,7 @@ mkChatItem cd ciId content quotedItem sharedMsgId itemTs createdAt = do tz <- getCurrentTimeZone currentTs <- liftIO getCurrentTime let itemText = ciContentToText content - meta = mkCIMeta ciId itemText ciStatusNew sharedMsgId False False tz currentTs itemTs createdAt + meta = mkCIMeta ciId content itemText ciStatusNew sharedMsgId False False tz currentTs itemTs createdAt pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem} allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m () @@ -1567,8 +1627,8 @@ chatCommandP = <|> "/_get items count=" *> (APIGetChatItems <$> A.decimal) <|> "/_send " *> (APISendMessage <$> chatTypeP <*> A.decimal <* A.space <*> msgContentP) <|> "/_send_quote " *> (APISendMessageQuote <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgContentP) - <|> "/_update item " *> (APIUpdateMessage <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgContentP) - <|> "/_delete item " *> (APIDeleteMessage <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgDeleteMode) + <|> "/_update item " *> (APIUpdateChatItem <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgContentP) + <|> "/_delete item " *> (APIDeleteChatItem <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> ciDeleteMode) <|> "/_read chat " *> (APIChatRead <$> chatTypeP <*> A.decimal <* A.space <*> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal))) <|> "/_delete " *> (APIDeleteChat <$> chatTypeP <*> A.decimal) <|> "/_accept " *> (APIAcceptContact <$> A.decimal) @@ -1631,7 +1691,7 @@ chatCommandP = msgContentP = "text " *> (MCText . safeDecodeUtf8 <$> A.takeByteString) <|> "json " *> jsonP - msgDeleteMode = "broadcast" $> MDBroadcast <|> "internal" $> MDInternal + ciDeleteMode = "broadcast" $> CIDMBroadcast <|> "internal" $> CIDMInternal displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ')) sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> A.takeByteString quotedMsg = A.char '(' *> A.takeTill (== ')') <* A.char ')' <* optional A.space diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index d2bb4bfeb..8b930d0eb 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -81,9 +81,6 @@ data ChatController = ChatController data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSQuotes deriving (Show, Generic) -data MsgDeleteMode = MDBroadcast | MDInternal - deriving (Show, Generic) - instance ToJSON HelpSection where toJSON = J.genericToJSON . enumJSON $ dropPrefix "HS" toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS" @@ -97,8 +94,8 @@ data ChatCommand | APIGetChatItems Int | APISendMessage ChatType Int64 MsgContent | APISendMessageQuote ChatType Int64 ChatItemId MsgContent - | APIUpdateMessage ChatType Int64 ChatItemId MsgContent - | APIDeleteMessage ChatType Int64 ChatItemId MsgDeleteMode + | APIUpdateChatItem ChatType Int64 ChatItemId MsgContent + | APIDeleteChatItem ChatType Int64 ChatItemId CIDeleteMode | APIChatRead ChatType Int64 (ChatItemId, ChatItemId) | APIDeleteChat ChatType Int64 | APIAcceptContact Int64 @@ -154,7 +151,7 @@ data ChatResponse | CRNewChatItem {chatItem :: AChatItem} | CRChatItemStatusUpdated {chatItem :: AChatItem} | CRChatItemUpdated {chatItem :: AChatItem} - | CRChatItemDeleted {chatItem :: AChatItem} + | CRChatItemDeleted {deletedChatItem :: AChatItem, toChatItem :: AChatItem} | CRMsgIntegrityError {msgerror :: MsgErrorType} -- TODO make it chat item to support in mobile | CRCmdAccepted {corr :: CorrId} | CRCmdOk @@ -303,7 +300,8 @@ data ChatErrorType | CEFileRcvChunk {message :: String} | CEFileInternal {message :: String} | CEInvalidQuote - | CEInvalidMessageUpdate + | CEInvalidChatItemUpdate + | CEInvalidChatItemDelete | CEAgentVersion | CECommandError {message :: String} deriving (Show, Exception, Generic) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 011b3c338..1a430ed83 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -214,10 +214,12 @@ data CIMeta (d :: MsgDirection) = CIMeta } deriving (Show, Generic) -mkCIMeta :: ChatItemId -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> CIMeta d -mkCIMeta itemId itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt = +mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> CIMeta d +mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt = let localItemTs = utcToZonedTime tz itemTs - editable = diffUTCTime currentTs itemTs < nominalDay + editable = case itemContent of + CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay + _ -> False in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, editable, localItemTs, createdAt} instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions @@ -336,19 +338,34 @@ jsonCIStatus = \case type ChatItemId = Int64 +type ChatItemTs = UTCTime + data ChatPagination = CPLast Int | CPAfter ChatItemId Int | CPBefore ChatItemId Int deriving (Show) -type ChatItemTs = UTCTime +data CIDeleteMode = CIDMBroadcast | CIDMInternal + deriving (Show, Generic) + +instance ToJSON CIDeleteMode where + toJSON = J.genericToJSON . enumJSON $ dropPrefix "CIDM" + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CIDM" + +instance FromJSON CIDeleteMode where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CIDM" + +ciDeleteModeToText :: CIDeleteMode -> Text +ciDeleteModeToText = \case + CIDMBroadcast -> "this item is deleted (broadcast)" + CIDMInternal -> "this item is deleted (internal)" data CIContent (d :: MsgDirection) where CISndMsgContent :: MsgContent -> CIContent 'MDSnd CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv - CISndMsgDeleted :: MsgContent -> CIContent 'MDSnd - CIRcvMsgDeleted :: MsgContent -> CIContent 'MDRcv + CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd + CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv CISndFileInvitation :: FileTransferId -> FilePath -> CIContent 'MDSnd CIRcvFileInvitation :: RcvFileTransfer -> CIContent 'MDRcv @@ -358,11 +375,16 @@ ciContentToText :: CIContent d -> Text ciContentToText = \case CISndMsgContent mc -> msgContentText mc CIRcvMsgContent mc -> msgContentText mc - CISndMsgDeleted _ -> "this message is deleted" - CIRcvMsgDeleted _ -> "this message is deleted" + CISndDeleted cidm -> ciDeleteModeToText cidm + CIRcvDeleted cidm -> ciDeleteModeToText cidm CISndFileInvitation fId fPath -> "you sent file #" <> T.pack (show fId) <> ": " <> T.pack fPath CIRcvFileInvitation RcvFileTransfer {fileInvitation = FileInvitation {fileName}} -> "file " <> T.pack fileName +msgDirToDeletedContent_ :: SMsgDirection d -> CIDeleteMode -> CIContent d +msgDirToDeletedContent_ msgDir mode = case msgDir of + SMDRcv -> CIRcvDeleted mode + SMDSnd -> CISndDeleted mode + -- platform independent instance ToField (CIContent d) where toField = toField . safeDecodeUtf8 . LB.toStrict . J.encode . dbJsonCIContent @@ -387,8 +409,8 @@ instance FromField ACIContent where fromField = fromTextField_ $ fmap aciContent data JSONCIContent = JCISndMsgContent {msgContent :: MsgContent} | JCIRcvMsgContent {msgContent :: MsgContent} - | JCISndMsgDeleted {msgContent :: MsgContent} - | JCIRcvMsgDeleted {msgContent :: MsgContent} + | JCISndDeleted {deleteMode :: CIDeleteMode} + | JCIRcvDeleted {deleteMode :: CIDeleteMode} | JCISndFileInvitation {fileId :: FileTransferId, filePath :: FilePath} | JCIRcvFileInvitation {rcvFileTransfer :: RcvFileTransfer} deriving (Generic) @@ -404,8 +426,8 @@ jsonCIContent :: CIContent d -> JSONCIContent jsonCIContent = \case CISndMsgContent mc -> JCISndMsgContent mc CIRcvMsgContent mc -> JCIRcvMsgContent mc - CISndMsgDeleted mc -> JCISndMsgDeleted mc - CIRcvMsgDeleted mc -> JCIRcvMsgDeleted mc + CISndDeleted cidm -> JCISndDeleted cidm + CIRcvDeleted cidm -> JCIRcvDeleted cidm CISndFileInvitation fId fPath -> JCISndFileInvitation fId fPath CIRcvFileInvitation ft -> JCIRcvFileInvitation ft @@ -413,8 +435,8 @@ aciContentJSON :: JSONCIContent -> ACIContent aciContentJSON = \case JCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc - JCISndMsgDeleted mc -> ACIContent SMDSnd $ CISndMsgDeleted mc - JCIRcvMsgDeleted mc -> ACIContent SMDRcv $ CIRcvMsgDeleted mc + JCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm + JCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm JCISndFileInvitation fId fPath -> ACIContent SMDSnd $ CISndFileInvitation fId fPath JCIRcvFileInvitation ft -> ACIContent SMDRcv $ CIRcvFileInvitation ft @@ -422,8 +444,8 @@ aciContentJSON = \case data DBJSONCIContent = DBJCISndMsgContent {msgContent :: MsgContent} | DBJCIRcvMsgContent {msgContent :: MsgContent} - | DBJCISndMsgDeleted {msgContent :: MsgContent} - | DBJCIRcvMsgDeleted {msgContent :: MsgContent} + | DBJCISndDeleted {deleteMode :: CIDeleteMode} + | DBJCIRcvDeleted {deleteMode :: CIDeleteMode} | DBJCISndFileInvitation {fileId :: FileTransferId, filePath :: FilePath} | DBJCIRcvFileInvitation {rcvFileTransfer :: RcvFileTransfer} deriving (Generic) @@ -439,8 +461,8 @@ dbJsonCIContent :: CIContent d -> DBJSONCIContent dbJsonCIContent = \case CISndMsgContent mc -> DBJCISndMsgContent mc CIRcvMsgContent mc -> DBJCIRcvMsgContent mc - CISndMsgDeleted mc -> DBJCISndMsgDeleted mc - CIRcvMsgDeleted mc -> DBJCIRcvMsgDeleted mc + CISndDeleted cidm -> DBJCISndDeleted cidm + CIRcvDeleted cidm -> DBJCIRcvDeleted cidm CISndFileInvitation fId fPath -> DBJCISndFileInvitation fId fPath CIRcvFileInvitation ft -> DBJCIRcvFileInvitation ft @@ -448,8 +470,8 @@ aciContentDBJSON :: DBJSONCIContent -> ACIContent aciContentDBJSON = \case DBJCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc DBJCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc - DBJCISndMsgDeleted ciId -> ACIContent SMDSnd $ CISndMsgDeleted ciId - DBJCIRcvMsgDeleted ciId -> ACIContent SMDRcv $ CIRcvMsgDeleted ciId + DBJCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm + DBJCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm DBJCISndFileInvitation fId fPath -> ACIContent SMDSnd $ CISndFileInvitation fId fPath DBJCIRcvFileInvitation ft -> ACIContent SMDRcv $ CIRcvFileInvitation ft diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index ff011ea8a..04df7a9a5 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -111,6 +111,7 @@ data ChatMsgEvent = XMsgNew MsgContainer | XMsgUpdate SharedMsgId MsgContent | XMsgDel SharedMsgId + | XMsgDeleted | XFile FileInvitation | XFileAcpt String | XInfo Profile @@ -236,6 +237,7 @@ data CMEventTag = XMsgNew_ | XMsgUpdate_ | XMsgDel_ + | XMsgDeleted_ | XFile_ | XFileAcpt_ | XInfo_ @@ -264,6 +266,7 @@ instance StrEncoding CMEventTag where XMsgNew_ -> "x.msg.new" XMsgUpdate_ -> "x.msg.update" XMsgDel_ -> "x.msg.del" + XMsgDeleted_ -> "x.msg.deleted" XFile_ -> "x.file" XFileAcpt_ -> "x.file.acpt" XInfo_ -> "x.info" @@ -289,6 +292,7 @@ instance StrEncoding CMEventTag where "x.msg.new" -> Right XMsgNew_ "x.msg.update" -> Right XMsgUpdate_ "x.msg.del" -> Right XMsgDel_ + "x.msg.deleted" -> Right XMsgDeleted_ "x.file" -> Right XFile_ "x.file.acpt" -> Right XFileAcpt_ "x.info" -> Right XInfo_ @@ -317,6 +321,7 @@ toCMEventTag = \case XMsgNew _ -> XMsgNew_ XMsgUpdate _ _ -> XMsgUpdate_ XMsgDel _ -> XMsgDel_ + XMsgDeleted -> XMsgDeleted_ XFile _ -> XFile_ XFileAcpt _ -> XFileAcpt_ XInfo _ -> XInfo_ @@ -360,9 +365,10 @@ appToChatMessage AppMessage {msgId, event, params} = do opt :: FromJSON a => J.Key -> Either String (Maybe a) opt key = JT.parseEither (.:? key) params msg = \case - XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params + XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" XMsgDel_ -> XMsgDel <$> p "msgId" + XMsgDeleted_ -> pure XMsgDeleted XFile_ -> XFile <$> p "file" XFileAcpt_ -> XFileAcpt <$> p "fileName" XInfo_ -> XInfo <$> p "profile" @@ -394,8 +400,9 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p key .=? value = maybe id ((:) . (key .=)) value params = case chatMsgEvent of XMsgNew container -> msgContainerJSON container - XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content] - XMsgDel msgId' -> o ["msgId" .= msgId'] + XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content] + XMsgDel msgId' -> o ["msgId" .= msgId'] + XMsgDeleted -> JM.empty XFile fileInv -> o ["file" .= fileInv] XFileAcpt fileName -> o ["fileName" .= fileName] XInfo profile -> o ["profile" .= profile] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 1ccc0c9ef..ed38209ed 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -120,15 +120,21 @@ module Simplex.Chat.Store getGroupChat, getChatItemIdByAgentMsgId, getDirectChatItem, + getDirectChatItemBySharedMsgId, getGroupChatItem, + getGroupChatItemBySharedMsgId, getDirectChatItemIdByText, getGroupChatItemIdByText, updateDirectChatItemStatus, updateDirectChatItem, - updateDirectChatItemByMsgId, - updateDirectChatItemsRead, + deleteDirectChatItemInternal, + deleteDirectChatItemRcvBroadcast, + deleteDirectChatItemSndBroadcast, updateGroupChatItem, - updateGroupChatItemByMsgId, + deleteGroupChatItemInternal, + deleteGroupChatItemRcvBroadcast, + deleteGroupChatItemSndBroadcast, + updateDirectChatItemsRead, updateGroupChatItemsRead, getSMPServers, overwriteSMPServers, @@ -152,7 +158,7 @@ import Data.Function (on) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (find, sortBy, sortOn) -import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Ord (Down (..)) import Data.Text (Text) import qualified Data.Text as T @@ -180,8 +186,8 @@ import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri, AgentMsgId, Conn import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (StrEncoding (strEncode)) import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) -import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Util (liftIOEither, (<$$>)) import System.FilePath (takeFileName) import UnliftIO.STM @@ -2041,21 +2047,18 @@ createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGr createNewSndMessage st gVar connOrGroupId mkMessage = liftIOEither . withTransaction st $ \db -> createWithRandomId gVar $ \sharedMsgId -> do + let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId createdAt <- getCurrentTime - DB.execute - db - "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, shared_msg_id, shared_msg_id_user, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (MDSnd, XUnknown_ "", "" :: MsgBody, sharedMsgId, Just True, createdAt, createdAt) - msgId <- insertedRowId db - let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId DB.execute db [sql| - UPDATE messages - SET msg_sent = ?, chat_msg_event = ?, msg_body = ?, connection_id = ?, group_id = ? - WHERE message_id = ? + INSERT INTO messages ( + msg_sent, chat_msg_event, msg_body, connection_id, group_id, + shared_msg_id, shared_msg_id_user, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?) |] - (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, msgId) + (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) + msgId <- insertedRowId db pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} where (connId_, groupId_) = case connOrGroupId of @@ -2214,7 +2217,7 @@ createNewRcvChatItem st user chatDirection RcvMessage {msgId, chatMsgEvent, shar (Just $ Just userMemberId == memberId, memberId) createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> UTCTime -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection msgId sharedMsgId ciContent quoteRow itemTs createdAt = do +createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemTs createdAt = do DB.execute db [sql| @@ -2227,10 +2230,11 @@ createNewChatItem_ db User {userId} chatDirection msgId sharedMsgId ciContent qu quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((userId, msgId) :. idsRow :. itemRow :. quoteRow) + ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) ciId <- insertedRowId db - when (isJust msgId) $ - DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, createdAt, createdAt) + case msgId_ of + Just msgId -> insertChatItemMessage_ db ciId msgId createdAt + Nothing -> pure () pure ciId where itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, UTCTime, UTCTime) @@ -2242,6 +2246,9 @@ createNewChatItem_ db User {userId} chatDirection msgId sharedMsgId ciContent qu CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) +insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime -> IO () +insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts) + getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c) getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = case chatDirection of @@ -2500,7 +2507,7 @@ getDirectChatLast_ db User {userId} contactId count = do ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent FROM chat_items i LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? + WHERE i.user_id = ? AND i.contact_id = ? AND i.item_deleted != 1 ORDER BY i.chat_item_id DESC LIMIT ? |] @@ -2528,7 +2535,7 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent FROM chat_items i LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id > ? + WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id > ? AND i.item_deleted != 1 ORDER BY i.chat_item_id ASC LIMIT ? |] @@ -2556,7 +2563,7 @@ getDirectChatBefore_ db User {userId} contactId beforeChatItemId count = do ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent FROM chat_items i LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id < ? + WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id < ? AND i.item_deleted != 1 ORDER BY i.chat_item_id DESC LIMIT ? |] @@ -2570,7 +2577,7 @@ getDirectChatStats_ db userId contactId = [sql| SELECT COUNT(1), MIN(chat_item_id) FROM chat_items - WHERE user_id = ? AND contact_id = ? AND item_status = ? + WHERE user_id = ? AND contact_id = ? AND item_status = ? AND item_deleted != 1 GROUP BY contact_id |] (userId, contactId, CISRcvNew) @@ -2668,7 +2675,7 @@ getGroupChatLast_ db user@User {userId, userContactId} groupId count = do LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id - WHERE i.user_id = ? AND i.group_id = ? + WHERE i.user_id = ? AND i.group_id = ? AND i.item_deleted != 1 ORDER BY i.item_ts DESC, i.chat_item_id DESC LIMIT ? |] @@ -2708,7 +2715,7 @@ getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id - WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id > ? + WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id > ? AND i.item_deleted != 1 ORDER BY i.item_ts ASC, i.chat_item_id ASC LIMIT ? |] @@ -2748,7 +2755,7 @@ getGroupChatBefore_ db user@User {userId, userContactId} groupId beforeChatItemI LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id - WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id < ? + WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id < ? AND i.item_deleted != 1 ORDER BY i.item_ts DESC, i.chat_item_id DESC LIMIT ? |] @@ -2762,7 +2769,7 @@ getGroupChatStats_ db userId groupId = [sql| SELECT COUNT(1), MIN(chat_item_id) FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_status = ? + WHERE user_id = ? AND group_id = ? AND item_status = ? AND item_deleted != 1 GROUP BY group_id |] (userId, groupId, CISRcvNew) @@ -2844,26 +2851,101 @@ updateDirectChatItem_ db userId contactId itemId newContent msgId = runExceptT $ ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId currentTs <- liftIO getCurrentTime let newText = ciContentToText newContent - liftIO $ + liftIO $ do DB.execute db [sql| UPDATE chat_items - SET item_content = ?, item_text = ?, item_edited = 1, updated_at = ? + SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = 1, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? |] (newContent, newText, currentTs, userId, contactId, itemId) - liftIO $ DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (itemId, msgId, currentTs, currentTs) + insertChatItemMessage_ db itemId msgId currentTs pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = True}, formattedText = parseMaybeMarkdownList newText} where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci -updateDirectChatItemByMsgId :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> CIContent d -> MessageId -> m (ChatItem 'CTDirect d) -updateDirectChatItemByMsgId st userId contactId sharedMsgId newContent msgId = +deleteDirectChatItemInternal :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> m AChatItem +deleteDirectChatItemInternal st userId ct itemId = + liftIOEither . withTransaction st $ \db -> do + currentTs <- liftIO getCurrentTime + ci <- deleteDirectChatItem_ db userId ct itemId CIDMInternal True currentTs + setChatItemMessagesDeleted_ db itemId + pure ci + +setChatItemMessagesDeleted_ :: DB.Connection -> ChatItemId -> IO () +setChatItemMessagesDeleted_ db itemId = + DB.execute + db + [sql| + UPDATE messages + SET chat_msg_event = ?, msg_body = ? + WHERE message_id IN ( + SELECT message_id + FROM chat_item_messages + WHERE chat_item_id = ? + ) + |] + (XMsgDeleted_, xMsgDeletedBody, itemId) + where + xMsgDeletedBody = strEncode ChatMessage {msgId = Nothing, chatMsgEvent = XMsgDeleted} + +deleteDirectChatItemRcvBroadcast :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> MessageId -> m AChatItem +deleteDirectChatItemRcvBroadcast st userId ct itemId msgId = + liftIOEither . withTransaction st $ \db -> deleteDirectChatItemBroadcast_ db userId ct itemId False msgId + +deleteDirectChatItemSndBroadcast :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> MessageId -> m AChatItem +deleteDirectChatItemSndBroadcast st userId ct itemId msgId = + liftIOEither . withTransaction st $ \db -> do + ci <- deleteDirectChatItemBroadcast_ db userId ct itemId True msgId + setChatItemMessagesDeleted_ db itemId + pure ci + +deleteDirectChatItemBroadcast_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> Bool -> MessageId -> IO (Either StoreError AChatItem) +deleteDirectChatItemBroadcast_ db userId ct itemId itemDeleted msgId = do + currentTs <- liftIO getCurrentTime + insertChatItemMessage_ db itemId msgId currentTs + deleteDirectChatItem_ db userId ct itemId CIDMBroadcast itemDeleted currentTs + +deleteDirectChatItem_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> Bool -> UTCTime -> IO (Either StoreError AChatItem) +deleteDirectChatItem_ db userId ct@Contact {contactId} itemId mode itemDeleted currentTs = runExceptT $ do + (CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId + let toContent = msgDirToDeletedContent_ msgDir mode + liftIO $ do + DB.execute + db + [sql| + UPDATE chat_items + SET item_content = ?, item_text = ?, item_deleted = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? + |] + (toContent, toText, itemDeleted, currentTs, userId, contactId, itemId) + when itemDeleted $ deleteQuote_ db itemId + pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted}, formattedText = Nothing}) + where + toText = ciDeleteModeToText mode + +deleteQuote_ :: DB.Connection -> ChatItemId -> IO () +deleteQuote_ db itemId = + DB.execute + db + [sql| + UPDATE chat_items + SET quoted_shared_msg_id = NULL, quoted_sent_at = NULL, quoted_content = NULL, quoted_sent = NULL, quoted_member_id = NULL + WHERE chat_item_id = ? + |] + (Only itemId) + +getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ChatItemId -> m (CChatItem 'CTDirect) +getDirectChatItem st userId contactId itemId = + liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId + +getDirectChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> m (CChatItem 'CTDirect) +getDirectChatItemBySharedMsgId st userId contactId sharedMsgId = liftIOEither . withTransaction st $ \db -> runExceptT $ do itemId <- ExceptT $ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId - liftIOEither $ updateDirectChatItem_ db userId contactId itemId newContent msgId + liftIOEither $ getDirectChatItem_ db userId contactId itemId getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> IO (Either StoreError Int64) getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = @@ -2879,10 +2961,6 @@ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = |] (userId, contactId, sharedMsgId) -getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ChatItemId -> m (CChatItem 'CTDirect) -getDirectChatItem st userId contactId itemId = - liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId - getDirectChatItem_ :: DB.Connection -> UserId -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTDirect)) getDirectChatItem_ db userId contactId itemId = do tz <- getCurrentTimeZone @@ -2928,26 +3006,73 @@ updateGroupChatItem_ db user@User {userId} groupId itemId newContent msgId = run ci <- ExceptT $ (correctDir =<<) <$> getGroupChatItem_ db user groupId itemId currentTs <- liftIO getCurrentTime let newText = ciContentToText newContent - liftIO $ + liftIO $ do DB.execute db [sql| UPDATE chat_items - SET item_content = ?, item_text = ?, item_edited = 1, updated_at = ? + SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = 1, updated_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (newContent, newText, currentTs, userId, groupId, itemId) - liftIO $ DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (itemId, msgId, currentTs, currentTs) + insertChatItemMessage_ db itemId msgId currentTs pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = True}, formattedText = parseMaybeMarkdownList newText} where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci -updateGroupChatItemByMsgId :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> User -> Int64 -> SharedMsgId -> CIContent d -> MessageId -> m (ChatItem 'CTGroup d) -updateGroupChatItemByMsgId st user groupId sharedMsgId newContent msgId = +deleteGroupChatItemInternal :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> ChatItemId -> m AChatItem +deleteGroupChatItemInternal st user gInfo itemId = + liftIOEither . withTransaction st $ \db -> do + currentTs <- liftIO getCurrentTime + ci <- deleteGroupChatItem_ db user gInfo itemId CIDMInternal True currentTs + setChatItemMessagesDeleted_ db itemId + pure ci + +deleteGroupChatItemRcvBroadcast :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> ChatItemId -> MessageId -> m AChatItem +deleteGroupChatItemRcvBroadcast st user gInfo itemId msgId = + liftIOEither . withTransaction st $ \db -> deleteGroupChatItemBroadcast_ db user gInfo itemId False msgId + +deleteGroupChatItemSndBroadcast :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> ChatItemId -> MessageId -> m AChatItem +deleteGroupChatItemSndBroadcast st user gInfo itemId msgId = + liftIOEither . withTransaction st $ \db -> do + ci <- deleteGroupChatItemBroadcast_ db user gInfo itemId True msgId + setChatItemMessagesDeleted_ db itemId + pure ci + +deleteGroupChatItemBroadcast_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Bool -> MessageId -> IO (Either StoreError AChatItem) +deleteGroupChatItemBroadcast_ db user gInfo itemId itemDeleted msgId = do + currentTs <- liftIO getCurrentTime + insertChatItemMessage_ db itemId msgId currentTs + deleteGroupChatItem_ db user gInfo itemId CIDMBroadcast itemDeleted currentTs + +deleteGroupChatItem_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> Bool -> UTCTime -> IO (Either StoreError AChatItem) +deleteGroupChatItem_ db user@User {userId} gInfo@GroupInfo {groupId} itemId mode itemDeleted currentTs = runExceptT $ do + (CChatItem msgDir ci) <- ExceptT $ getGroupChatItem_ db user groupId itemId + let toContent = msgDirToDeletedContent_ msgDir mode + liftIO $ do + DB.execute + db + [sql| + UPDATE chat_items + SET item_content = ?, item_text = ?, item_deleted = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (toContent, toText, itemDeleted, currentTs, userId, groupId, itemId) + when itemDeleted $ deleteQuote_ db itemId + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted}, formattedText = Nothing}) + where + toText = ciDeleteModeToText mode + +getGroupChatItem :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatItemId -> m (CChatItem 'CTGroup) +getGroupChatItem st user groupId itemId = + liftIOEither . withTransaction st $ \db -> getGroupChatItem_ db user groupId itemId + +getGroupChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> User -> Int64 -> SharedMsgId -> m (CChatItem 'CTGroup) +getGroupChatItemBySharedMsgId st user groupId sharedMsgId = liftIOEither . withTransaction st $ \db -> runExceptT $ do itemId <- ExceptT $ getGroupChatItemIdBySharedMsgId_ db user groupId sharedMsgId - liftIOEither $ updateGroupChatItem_ db user groupId itemId newContent msgId + liftIOEither $ getGroupChatItem_ db user groupId itemId getGroupChatItemIdBySharedMsgId_ :: DB.Connection -> User -> Int64 -> SharedMsgId -> IO (Either StoreError Int64) getGroupChatItemIdBySharedMsgId_ db User {userId} groupId sharedMsgId = @@ -2963,10 +3088,6 @@ getGroupChatItemIdBySharedMsgId_ db User {userId} groupId sharedMsgId = |] (userId, groupId, sharedMsgId) -getGroupChatItem :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatItemId -> m (CChatItem 'CTGroup) -getGroupChatItem st user groupId itemId = - liftIOEither . withTransaction st $ \db -> getGroupChatItem_ db user groupId itemId - getGroupChatItem_ :: DB.Connection -> User -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTGroup)) getGroupChatItem_ db User {userId, userContactId} groupId itemId = do tz <- getCurrentTimeZone @@ -3106,10 +3227,10 @@ toDirectChatItem tz currentTs ((itemId, itemTs, itemContent, itemText, itemStatu where cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> CChatItem 'CTDirect cItem d chatDir ciStatus content = - CChatItem d ChatItem {chatDir, meta = ciMeta ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow} + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow} badItem = Left $ SEBadChatItem itemId - ciMeta :: CIStatus d -> CIMeta d - ciMeta status = mkCIMeta itemId itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt + ciMeta :: CIContent d -> CIStatus d -> CIMeta d + ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] toDirectChatItemList tz currentTs ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. quoteRow) = @@ -3139,10 +3260,10 @@ toGroupChatItem tz currentTs userContactId ((itemId, itemTs, itemContent, itemTe where cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> CChatItem 'CTGroup cItem d chatDir ciStatus content quotedMember_ = - CChatItem d ChatItem {chatDir, meta = ciMeta ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_} + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_} badItem = Left $ SEBadChatItem itemId - ciMeta :: CIStatus d -> CIMeta d - ciMeta status = mkCIMeta itemId itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt + ciMeta :: CIContent d -> CIStatus d -> CIMeta d + ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] toGroupChatItemList tz currentTs userContactId ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 61e514b32..6929b6921 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -49,8 +49,8 @@ responseToView testView = \case CRUserSMPServers smpServers -> viewSMPServers smpServers testView CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item CRChatItemStatusUpdated _ -> [] - CRChatItemUpdated (AChatItem _ _ chat item) -> viewMessageUpdate chat item - CRChatItemDeleted _ -> [] -- TODO + CRChatItemUpdated (AChatItem _ _ chat item) -> viewItemUpdate chat item + CRChatItemDeleted (AChatItem _ _ chat deletedItem) (AChatItem _ _ _ toItem) -> viewItemDelete chat deletedItem toItem CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr CRCmdAccepted _ -> [] CRCmdOk -> ["ok"] @@ -168,13 +168,13 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem} = case chat of DirectChat c -> case chatDir of CIDirectSnd -> case content of CISndMsgContent mc -> viewSentMessage to quote mc meta - CISndMsgDeleted _mc -> [] + CISndDeleted _ -> [] CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta where to = ttyToContact' c CIDirectRcv -> case content of CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc - CIRcvMsgDeleted _mc -> [] + CIRcvDeleted _ -> [] CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft where from = ttyFromContact' c @@ -183,13 +183,13 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem} = case chat of GroupChat g -> case chatDir of CIGroupSnd -> case content of CISndMsgContent mc -> viewSentMessage to quote mc meta - CISndMsgDeleted _mc -> [] + CISndDeleted _ -> [] CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta where to = ttyToGroup g CIGroupRcv m -> case content of CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc - CIRcvMsgDeleted _mc -> [] + CIRcvDeleted _ -> [] CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft where from = ttyFromGroup' g m @@ -197,8 +197,8 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem} = case chat of quote = maybe [] (groupQuote g) quotedItem _ -> [] -viewMessageUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> [StyledString] -viewMessageUpdate chat ChatItem {chatDir, meta, content, quotedItem} = case chat of +viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> [StyledString] +viewItemUpdate chat ChatItem {chatDir, meta, content, quotedItem} = case chat of DirectChat Contact {localDisplayName = c} -> case chatDir of CIDirectRcv -> case content of CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc @@ -206,7 +206,7 @@ viewMessageUpdate chat ChatItem {chatDir, meta, content, quotedItem} = case chat where from = ttyFromContactEdited c quote = maybe [] (directQuote chatDir) quotedItem - CIDirectSnd -> [] + CIDirectSnd -> ["item updated"] GroupChat g -> case chatDir of CIGroupRcv GroupMember {localDisplayName = m} -> case content of CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc @@ -214,8 +214,23 @@ viewMessageUpdate chat ChatItem {chatDir, meta, content, quotedItem} = case chat where from = ttyFromGroupEdited g m quote = maybe [] (groupQuote g) quotedItem - CIGroupSnd -> [] - where + CIGroupSnd -> ["item updated"] + _ -> [] + +viewItemDelete :: ChatInfo c -> ChatItem c d -> ChatItem c' d' -> [StyledString] +viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} ChatItem {content = toContent} = case chat of + DirectChat Contact {localDisplayName = c} -> case (chatDir, deletedContent, toContent) of + (CIDirectRcv, CIRcvMsgContent mc, CIRcvDeleted mode) -> case mode of + CIDMBroadcast -> viewReceivedMessage (ttyFromContactDeleted c) [] meta mc + CIDMInternal -> ["item deleted"] + (CIDirectSnd, _, _) -> ["item deleted"] + _ -> [] + GroupChat g -> case (chatDir, deletedContent, toContent) of + (CIGroupRcv GroupMember {localDisplayName = m}, CIRcvMsgContent mc, CIRcvDeleted mode) -> case mode of + CIDMBroadcast -> viewReceivedMessage (ttyFromGroupDeleted g m) [] meta mc + CIDMInternal -> ["item deleted"] + (CIGroupSnd, _, _) -> ["item deleted"] + _ -> [] _ -> [] directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString] @@ -585,7 +600,8 @@ viewChatError = \case CEFileRcvChunk e -> ["error receiving file: " <> plain e] CEFileInternal e -> ["file error: " <> plain e] CEInvalidQuote -> ["cannot reply to this message"] - CEInvalidMessageUpdate -> ["cannot update this message"] + CEInvalidChatItemUpdate -> ["cannot update this item"] + CEInvalidChatItemDelete -> ["cannot delete this item"] CEAgentVersion -> ["unsupported agent version"] CECommandError e -> ["bad chat command: " <> plain e] -- e -> ["chat error: " <> sShow e] @@ -639,6 +655,9 @@ ttyFromContact c = ttyFrom $ c <> "> " ttyFromContactEdited :: ContactName -> StyledString ttyFromContactEdited c = ttyFrom $ c <> "> [edited] " +ttyFromContactDeleted :: ContactName -> StyledString +ttyFromContactDeleted c = ttyFrom $ c <> "> [deleted] " + ttyToContact' :: Contact -> StyledString ttyToContact' Contact {localDisplayName = c} = ttyToContact c @@ -673,6 +692,9 @@ 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] " + ttyFrom :: Text -> StyledString ttyFrom = styled $ colored Yellow diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 19b28a7cb..b8583dcd7 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -36,6 +36,7 @@ chatTests = do it "add contact and send/receive message" testAddContact it "direct message quoted replies" testDirectMessageQuotedReply it "direct message update" testDirectMessageUpdate + it "direct message delete" testDirectMessageDelete describe "chat groups" $ do it "add contacts, create group and send/receive messages" testGroup it "create and join group with 4 members" testGroup2 @@ -46,6 +47,7 @@ chatTests = do it "list groups containing group invitations" testGroupList it "group message quoted replies" testGroupMessageQuotedReply it "group message update" testGroupMessageUpdate + it "group message delete" testGroupMessageDelete describe "user profiles" $ do it "update user profiles and notify contacts" testUpdateProfile it "update user profile with image" testUpdateProfileImage @@ -128,7 +130,7 @@ testAddContact = bob #$> ("/_read chat @2 from=1 to=100", id, "ok") testDirectMessageQuotedReply :: IO () -testDirectMessageQuotedReply = do +testDirectMessageQuotedReply = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob @@ -153,7 +155,7 @@ testDirectMessageQuotedReply = do alice #$> ("/_get chat @2 count=1", chat', [((0, "will tell more"), Just (0, "all good - you?"))]) testDirectMessageUpdate :: IO () -testDirectMessageUpdate = do +testDirectMessageUpdate = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob @@ -172,7 +174,7 @@ testDirectMessageUpdate = do alice #$> ("/_get chat @2 count=100", chat', [((1, "hello 🙂"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂"))]) bob #$> ("/_get chat @2 count=100", chat', [((0, "hello 🙂"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂"))]) - alice ##> "/_update item @2 1 text hey 👋" + alice #$> ("/_update item @2 1 text hey 👋", id, "item updated") bob <# "alice> [edited] hey 👋" alice #$> ("/_get chat @2 count=100", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂"))]) @@ -188,23 +190,75 @@ testDirectMessageUpdate = do alice #$> ("/_get chat @2 count=100", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂")), ((0, "hey alice"), Just (1, "hey 👋"))]) bob #$> ("/_get chat @2 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂")), ((1, "hey alice"), Just (0, "hey 👋"))]) - alice ##> "/_update item @2 1 text greetings 🤝" + alice #$> ("/_update item @2 1 text greetings 🤝", id, "item updated") bob <# "alice> [edited] greetings 🤝" + alice #$> ("/_update item @2 2 text updating bob's message", id, "cannot update this item") + alice #$> ("/_get chat @2 count=100", chat', [((1, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂")), ((0, "hey alice"), Just (1, "hey 👋"))]) bob #$> ("/_get chat @2 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂")), ((1, "hey alice"), Just (0, "hey 👋"))]) - bob ##> "/_update item @2 2 text hey Alice" + bob #$> ("/_update item @2 2 text hey Alice", id, "item updated") alice <# "bob> [edited] > hello 🙂" alice <## " hey Alice" - bob ##> "/_update item @2 3 text greetings Alice" + bob #$> ("/_update item @2 3 text greetings Alice", id, "item updated") alice <# "bob> [edited] > hey 👋" alice <## " greetings Alice" alice #$> ("/_get chat @2 count=100", chat', [((1, "greetings 🤝"), Nothing), ((0, "hey Alice"), Just (1, "hello 🙂")), ((0, "greetings Alice"), Just (1, "hey 👋"))]) bob #$> ("/_get chat @2 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hey Alice"), Just (0, "hello 🙂")), ((1, "greetings Alice"), Just (0, "hey 👋"))]) +testDirectMessageDelete :: IO () +testDirectMessageDelete = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + + -- msg id 1 + alice #> "@bob hello 🙂" + bob <# "alice> hello 🙂" + + -- msg id 2 + bob `send` "> @alice (hello) hey alic" + bob <# "@alice > hello 🙂" + bob <## " hey alic" + alice <# "bob> > hello 🙂" + alice <## " hey alic" + + alice #$> ("/_delete item @2 1 internal", id, "item deleted") + alice #$> ("/_delete item @2 2 internal", id, "item deleted") + + alice #$$> ("/_get chats", [("@bob", "")]) + alice #$> ("/_get chat @2 count=100", chat, []) + + alice #$> ("/_update item @2 1 text updating deleted message", id, "cannot update this item") + alice #$> ("/_send_quote @2 1 text quoting deleted message", id, "cannot reply to this message") + + bob #$> ("/_update item @2 2 text hey alice", id, "item updated") + alice <# "bob> [edited] hey alice" + + alice #$$> ("/_get chats", [("@bob", "hey alice")]) + alice #$> ("/_get chat @2 count=100", chat, [(0, "hey alice")]) + + -- msg id 3 + bob #> "@alice how are you?" + alice <# "bob> how are you?" + + bob #$> ("/_delete item @2 3 broadcast", id, "item deleted") + alice <# "bob> [deleted] how are you?" + + alice #$> ("/_delete item @2 1 broadcast", id, "item deleted") + bob <# "alice> [deleted] hello 🙂" + + alice #$> ("/_delete item @2 2 broadcast", id, "cannot delete this item") + alice #$> ("/_delete item @2 2 internal", id, "item deleted") + + alice #$$> ("/_get chats", [("@bob", "this item is deleted (broadcast)")]) + alice #$> ("/_get chat @2 count=100", chat, [(0, "this item is deleted (broadcast)")]) + bob #$$> ("/_get chats", [("@alice", "hey alice")]) + bob #$> ("/_get chat @2 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hey alice"), (Just (0, "hello 🙂")))]) + testGroup :: IO () testGroup = testChat3 aliceProfile bobProfile cathProfile $ @@ -688,16 +742,17 @@ testGroupMessageQuotedReply = ) testGroupMessageUpdate :: IO () -testGroupMessageUpdate = do +testGroupMessageUpdate = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath + -- msg id 1 alice #> "#team hello!" concurrently_ (bob <# "#team alice> hello!") (cath <# "#team alice> hello!") - alice ##> "/_update item #1 1 text hey 👋" + alice #$> ("/_update item #1 1 text hey 👋", id, "item updated") concurrently_ (bob <# "#team alice> [edited] hey 👋") (cath <# "#team alice> [edited] hey 👋") @@ -707,6 +762,7 @@ testGroupMessageUpdate = do cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing)]) threadDelay 1000000 + -- msg id 2 bob `send` "> #team @alice (hey) hi alice" bob <# "#team > alice hey 👋" bob <## " hi alice" @@ -724,11 +780,13 @@ testGroupMessageUpdate = do bob #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hey 👋"))]) cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((0, "hi alice"), Just (0, "hey 👋"))]) - alice ##> "/_update item #1 1 text greetings 🤝" + alice #$> ("/_update item #1 1 text greetings 🤝", id, "item updated") concurrently_ (bob <# "#team alice> [edited] greetings 🤝") (cath <# "#team alice> [edited] greetings 🤝") + alice #$> ("/_update item #1 2 text updating bob's message", id, "cannot update this item") + threadDelay 1000000 cath `send` "> #team @alice (greetings) greetings!" cath <# "#team > alice greetings 🤝" @@ -747,6 +805,87 @@ testGroupMessageUpdate = do bob #$> ("/_get chat #1 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hey 👋")), ((0, "greetings!"), Just (0, "greetings 🤝"))]) cath #$> ("/_get chat #1 count=100", chat', [((0, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (0, "hey 👋")), ((1, "greetings!"), Just (0, "greetings 🤝"))]) +testGroupMessageDelete :: IO () +testGroupMessageDelete = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + -- msg id 1 + alice #> "#team hello!" + concurrently_ + (bob <# "#team alice> hello!") + (cath <# "#team alice> hello!") + + alice #$> ("/_delete item #1 1 internal", id, "item deleted") + + alice #$> ("/_get chat #1 count=100", chat, []) + bob #$> ("/_get chat #1 count=100", chat, [(0, "hello!")]) + cath #$> ("/_get chat #1 count=100", chat, [(0, "hello!")]) + + alice #$> ("/_update item #1 1 text updating deleted message", id, "cannot update this item") + alice #$> ("/_send_quote #1 1 text quoting deleted message", id, "cannot reply to this message") + + threadDelay 1000000 + -- msg id 2 + bob `send` "> #team @alice (hello) hi alic" + bob <# "#team > alice hello!" + bob <## " hi alic" + concurrently_ + ( do + alice <# "#team bob> > alice hello!" + alice <## " hi alic" + ) + ( do + cath <# "#team bob> > alice hello!" + cath <## " hi alic" + ) + + alice #$> ("/_get chat #1 count=100", chat', [((0, "hi alic"), Just (1, "hello!"))]) + bob #$> ("/_get chat #1 count=100", chat', [((0, "hello!"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) + cath #$> ("/_get chat #1 count=100", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) + + alice #$> ("/_delete item #1 1 broadcast", id, "item deleted") + concurrently_ + (bob <# "#team alice> [deleted] hello!") + (cath <# "#team alice> [deleted] hello!") + + alice #$> ("/_delete item #1 2 internal", id, "item deleted") + + alice #$> ("/_get chat #1 count=100", chat', []) + bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) + cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) + + bob #$> ("/_update item #1 2 text hi alice", id, "item updated") + concurrently_ + (alice <# "#team bob> [edited] hi alice") + ( do + cath <# "#team bob> [edited] > alice hello!" + cath <## " hi alice" + ) + + alice #$> ("/_get chat #1 count=100", chat', [((0, "hi alice"), Nothing)]) + bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!"))]) + cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) + + threadDelay 1000000 + -- msg id 3 + cath #> "#team how are you?" + concurrently_ + (alice <# "#team cath> how are you?") + (bob <# "#team cath> how are you?") + + cath #$> ("/_delete item #1 3 broadcast", id, "item deleted") + concurrently_ + (alice <# "#team cath> [deleted] how are you?") + (bob <# "#team cath> [deleted] how are you?") + + alice #$> ("/_delete item #1 2 broadcast", id, "cannot delete this item") + alice #$> ("/_delete item #1 2 internal", id, "item deleted") + + alice #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing)]) + bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "this item is deleted (broadcast)"), Nothing)]) + cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) + testUpdateProfile :: IO () testUpdateProfile = testChat3 aliceProfile bobProfile cathProfile $