diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 912a57bf20..41e06b0bdc 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -334,15 +334,16 @@ processChatCommand = \case case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do deleteCIFile user file - toCi <- withStore $ \st -> deleteDirectChatItemInternal st userId ct itemId + toCi <- withStore $ \st -> deleteDirectChatItemLocal st userId ct itemId CIDMInternal pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do - SndMessage {msgId} <- sendDirectContactMessage ct (XMsgDel itemSharedMId) + void $ sendDirectContactMessage ct (XMsgDel itemSharedMId) deleteCIFile user file - toCi <- withStore $ \st -> deleteDirectChatItemSndBroadcast st userId ct itemId msgId + toCi <- withStore $ \st -> deleteDirectChatItemLocal st userId ct itemId CIDMBroadcast setActive $ ActiveC c pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (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 $ \st -> getGroup st user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved @@ -365,9 +366,9 @@ processChatCommand = \case deleteCIFile :: MsgDirectionI d => User -> Maybe (CIFile d) -> m () deleteCIFile user file = forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do - cancelFiles user [(fileId, AFS msgDirection fileStatus)] - withFilesFolder $ \filesFolder -> - deleteFiles filesFolder [filePath] + let fileInfo = CIFileInfo {fileId, fileStatus = AFS msgDirection fileStatus, filePath} + cancelFile user fileInfo + withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo APIChatRead (ChatRef cType chatId) fromToIds -> withChatLock $ case cType of CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk CTGroup -> withStore (\st -> updateGroupChatItemsRead st chatId fromToIds) $> CRCmdOk @@ -378,12 +379,12 @@ processChatCommand = \case ct@Contact {localDisplayName} <- withStore $ \st -> getContact st userId chatId withStore (\st -> getContactGroupNames st userId ct) >>= \case [] -> do - files <- withStore $ \st -> getContactFiles st userId ct + filesInfo <- withStore $ \st -> getContactFileInfo st userId ct conns <- withStore $ \st -> getContactConnections st userId ct withChatLock . procCmd $ do - cancelFiles user (map (\(fId, fStatus, _) -> (fId, fStatus)) files) - withFilesFolder $ \filesFolder -> - deleteFiles filesFolder (map (\(_, _, fPath) -> fPath) files) + forM_ filesInfo $ \fileInfo -> do + cancelFile user fileInfo + withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () withStore $ \st -> deleteContact st userId ct @@ -397,6 +398,27 @@ processChatCommand = \case pure $ CRContactConnectionDeleted conn CTGroup -> pure $ chatCmdError "not implemented" CTContactRequest -> pure $ chatCmdError "not supported" + APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of + CTDirect -> do + ct <- withStore $ \st -> getContact st userId chatId + ciIdsAndFileInfo <- withStore $ \st -> getContactChatItemIdsAndFileInfo st userId chatId + forM_ ciIdsAndFileInfo $ \(itemId, fileInfo_) -> do + forM_ fileInfo_ $ \fileInfo -> do + cancelFile user fileInfo + withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo + void $ withStore $ \st -> deleteDirectChatItemLocal st userId ct itemId CIDMInternal + pure $ CRChatCleared (AChatInfo SCTDirect (DirectChat ct)) + CTGroup -> do + gInfo <- withStore $ \st -> getGroupInfo st user chatId + ciIdsAndFileInfo <- withStore $ \st -> getGroupChatItemIdsAndFileInfo st userId chatId + forM_ ciIdsAndFileInfo $ \(itemId, fileInfo_) -> do + forM_ fileInfo_ $ \fileInfo -> do + cancelFile user fileInfo + withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo + void $ withStore $ \st -> deleteGroupChatItemInternal st user gInfo itemId + pure $ CRChatCleared (AChatInfo SCTGroup (GroupChat gInfo)) + CTContactConnection -> pure $ chatCmdError "not supported" + CTContactRequest -> pure $ chatCmdError "not supported" APIAcceptContact connReqId -> withUser $ \user@User {userId} -> withChatLock $ do cReq <- withStore $ \st -> getContactRequest st userId connReqId procCmd $ CRAcceptingContactRequest <$> acceptContactRequest user cReq @@ -507,6 +529,9 @@ processChatCommand = \case DeleteContact cName -> withUser $ \User {userId} -> do contactId <- withStore $ \st -> getContactIdByName st userId cName processChatCommand $ APIDeleteChat (ChatRef CTDirect contactId) + ClearContact cName -> withUser $ \User {userId} -> do + contactId <- withStore $ \st -> getContactIdByName st userId cName + processChatCommand $ APIClearChat (ChatRef CTDirect contactId) ListContacts -> withUser $ \user -> CRContactsList <$> withStore (`getUserContacts` user) CreateMyAddress -> withUser $ \User {userId} -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMContact) @@ -629,6 +654,9 @@ processChatCommand = \case mapM_ deleteMemberConnection members withStore $ \st -> deleteGroup st user g pure $ CRGroupDeletedUser gInfo + ClearGroup gName -> withUser $ \user -> do + groupId <- withStore $ \st -> getGroupIdByName st user gName + processChatCommand $ APIClearChat (ChatRef CTGroup groupId) ListMembers gName -> CRGroupMembers <$> withUser (\user -> withStore (\st -> getGroupByName st user gName)) ListGroups -> CRGroupsList <$> withUser (\user -> withStore (`getUserGroupDetails` user)) SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do @@ -754,15 +782,14 @@ processChatCommand = \case -- perform an action only if filesFolder is set (i.e. on mobile devices) withFilesFolder :: (FilePath -> m ()) -> m () withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action - deleteFiles :: FilePath -> [Maybe FilePath] -> m () - deleteFiles filesFolder filePaths = - forM_ filePaths $ \filePath_ -> - forM_ filePath_ $ \filePath -> do - let fsFilePath = filesFolder <> "/" <> filePath - removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> - removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () - cancelFiles :: User -> [(Int64, ACIFileStatus)] -> m () - cancelFiles user files = forM_ files $ \(fileId, AFS dir status) -> + deleteFile :: FilePath -> CIFileInfo -> m () + deleteFile filesFolder CIFileInfo {filePath} = + forM_ filePath $ \fPath -> do + let fsFilePath = filesFolder <> "/" <> fPath + removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> + removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () + cancelFile :: User -> CIFileInfo -> m () + cancelFile user CIFileInfo {fileId, fileStatus = (AFS dir status)} = unless (ciFileEnded status) $ case dir of SMDSnd -> do @@ -1416,23 +1443,41 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage pure $ Just ciFile messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m () - messageUpdate ct@Contact {contactId} sharedMsgId mc RcvMessage {msgId} msgMeta = do + messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta = do checkIntegrity msgMeta $ toView . CRMsgIntegrityError - CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId - case msgDir of - SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv $ CIRcvMsgContent mc) $ Just msgId - SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" + updateRcvChatItem `catchError` \e -> + case e of + (ChatErrorStore (SEChatItemSharedMsgIdNotFound _)) -> do + -- This patches initial sharedMsgId into chat item when locally deleted chat item + -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). + -- Chat item and update message which created it will have different sharedMsgId in this case... + ci@ChatItem {formattedText} <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci + showMsgToast (c <> "> ") mc formattedText + setActive $ ActiveC c + _ -> throwError e + where + updateRcvChatItem = do + CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId + case msgDir of + SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv $ CIRcvMsgContent mc) $ Just msgId + SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta = do checkIntegrity msgMeta $ toView . CRMsgIntegrityError - CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId - case msgDir of - SMDRcv -> do - -- TODO allow to locally delete items that were broadcast deleted by sender - toCi <- withStore $ \st -> deleteDirectChatItemRcvBroadcast st userId ct itemId msgId - toView $ CRChatItemDeleted (AChatItem SCTDirect SMDRcv (DirectChat ct) deletedItem) toCi - SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" + deleteRcvChatItem `catchError` \e -> + case e of + (ChatErrorStore (SEChatItemSharedMsgIdNotFound sMsgId)) -> toView $ CRChatItemDeletedNotFound ct sMsgId + _ -> throwError e + where + deleteRcvChatItem = 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 + SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m () newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do @@ -1989,9 +2034,12 @@ saveSndChatItem user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem = liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) createdAt createdAt saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> m (ChatItem c 'MDRcv) -saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} MsgMeta {broker = (_, brokerTs)} content ciFile = do +saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} = saveRcvChatItem' user cd msg sharedMsgId_ + +saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> m (ChatItem c 'MDRcv) +saveRcvChatItem' user cd msg sharedMsgId_ MsgMeta {broker = (_, brokerTs)} content ciFile = do createdAt <- liftIO getCurrentTime - (ciId, quotedItem) <- withStore $ \st -> createNewRcvChatItem st user cd msg content brokerTs createdAt + (ciId, quotedItem) <- withStore $ \st -> createNewRcvChatItem st user cd msg sharedMsgId_ content brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> withStore $ \st -> updateFileTransferChatItemId st fileId ciId liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ brokerTs createdAt @@ -2124,6 +2172,7 @@ chatCommandP = <|> "/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode) <|> "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))) <|> "/_delete " *> (APIDeleteChat <$> chatRefP) + <|> "/_clear chat " *> (APIClearChat <$> chatRefP) <|> "/_accept " *> (APIAcceptContact <$> A.decimal) <|> "/_reject " *> (APIRejectContact <$> A.decimal) <|> "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP) @@ -2153,6 +2202,9 @@ chatCommandP = <|> ("/remove #" <|> "/remove " <|> "/rm #" <|> "/rm ") *> (RemoveMember <$> displayName <* A.space <*> displayName) <|> ("/leave #" <|> "/leave " <|> "/l #" <|> "/l ") *> (LeaveGroup <$> displayName) <|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName) + <|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName) + <|> "/clear #" *> (ClearGroup <$> displayName) + <|> ("/clear @" <|> "/clear ") *> (ClearContact <$> displayName) <|> ("/members #" <|> "/members " <|> "/ms #" <|> "/ms ") *> (ListMembers <$> displayName) <|> ("/groups" <|> "/gs") $> ListGroups <|> (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> A.takeByteString) @@ -2160,7 +2212,6 @@ chatCommandP = <|> ("/contacts" <|> "/cs") $> ListContacts <|> ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeByteString $> Nothing)) <|> ("/connect" <|> "/c") $> AddContact - <|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName) <|> (SendMessage <$> chatNameP <* A.space <*> A.takeByteString) <|> (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv) <|> (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1de9da5371..d197e0a215 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -109,6 +109,7 @@ data ChatCommand | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) | APIDeleteChat ChatRef + | APIClearChat ChatRef | APIAcceptContact Int64 | APIRejectContact Int64 | APISendCallInvitation ContactId CallType @@ -132,6 +133,7 @@ data ChatCommand | Connect (Maybe AConnectionRequestUri) | ConnectSimplex | DeleteContact ContactName + | ClearContact ContactName | ListContacts | CreateMyAddress | DeleteMyAddress @@ -151,6 +153,7 @@ data ChatCommand | MemberRole GroupName ContactName GroupMemberRole | LeaveGroup GroupName | DeleteGroup GroupName + | ClearGroup GroupName | ListMembers GroupName | ListGroups | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: ByteString, message :: ByteString} @@ -179,6 +182,7 @@ data ChatResponse | CRChatItemStatusUpdated {chatItem :: AChatItem} | CRChatItemUpdated {chatItem :: AChatItem} | CRChatItemDeleted {deletedChatItem :: AChatItem, toChatItem :: AChatItem} + | CRChatItemDeletedNotFound {contact :: Contact, sharedMsgId :: SharedMsgId} | CRBroadcastSent MsgContent Int ZonedTime | CRMsgIntegrityError {msgerror :: MsgErrorType} -- TODO make it chat item to support in mobile | CRCmdAccepted {corr :: CorrId} @@ -205,6 +209,7 @@ data ChatResponse | CRContactUpdated {fromContact :: Contact, toContact :: Contact} | CRContactsMerged {intoContact :: Contact, mergedContact :: Contact} | CRContactDeleted {contact :: Contact} + | CRChatCleared {chatInfo :: AChatInfo} | CRUserContactLinkCreated {connReqContact :: ConnReqContact} | CRUserContactLinkDeleted | CRReceivedContactRequest {contactRequest :: UserContactRequest} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 47e0aa8218..5febc79ca2 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -82,6 +82,14 @@ jsonChatInfo = \case ContactRequest g -> JCInfoContactRequest g ContactConnection c -> JCInfoContactConnection c +data AChatInfo = forall c. AChatInfo (SChatType c) (ChatInfo c) + +deriving instance Show AChatInfo + +instance ToJSON AChatInfo where + toJSON (AChatInfo _ c) = J.toJSON c + toEncoding (AChatInfo _ c) = J.toEncoding c + data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem { chatDir :: CIDirection c d, meta :: CIMeta d, @@ -363,6 +371,13 @@ instance StrEncoding ACIFileStatus where "rcv_cancelled" -> pure $ AFS SMDRcv CIFSRcvCancelled _ -> fail "bad file status" +-- to conveniently read file data from db +data CIFileInfo = CIFileInfo + { fileId :: Int64, + fileStatus :: ACIFileStatus, + filePath :: Maybe FilePath + } + data CIStatus (d :: MsgDirection) where CISSndNew :: CIStatus 'MDSnd CISSndSent :: CIStatus 'MDSnd diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 98a2e440de..2886356700 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -116,7 +116,9 @@ module Simplex.Chat.Store getFileTransfer, getFileTransferProgress, getSndFileTransfer, - getContactFiles, + getContactFileInfo, + getContactChatItemIdsAndFileInfo, + getGroupChatItemIdsAndFileInfo, createNewSndMessage, createSndMsgDelivery, createNewMessageAndRcvMsgDelivery, @@ -143,9 +145,8 @@ module Simplex.Chat.Store updateDirectChatItemStatus, updateDirectCIFileStatus, updateDirectChatItem, - deleteDirectChatItemInternal, + deleteDirectChatItemLocal, deleteDirectChatItemRcvBroadcast, - deleteDirectChatItemSndBroadcast, updateGroupChatItem, deleteGroupChatItemInternal, deleteGroupChatItemRcvBroadcast, @@ -2280,18 +2281,56 @@ getFileTransferMeta_ db userId fileId = fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) = FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_} -getContactFiles :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [(Int64, ACIFileStatus, Maybe FilePath)] -getContactFiles st userId Contact {contactId} = +getContactFileInfo :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [CIFileInfo] +getContactFileInfo st userId Contact {contactId} = liftIO . withTransaction st $ \db -> - DB.query - db - [sql| + map toFileInfo + <$> DB.query + db + [sql| SELECT f.file_id, f.ci_file_status, f.file_path FROM chat_items i JOIN files f ON f.chat_item_id = i.chat_item_id WHERE i.user_id = ? AND i.contact_id = ? |] - (userId, contactId) + (userId, contactId) + +toFileInfo :: (Int64, ACIFileStatus, Maybe FilePath) -> CIFileInfo +toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath} + +getContactChatItemIdsAndFileInfo :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactId -> m [(ChatItemId, Maybe CIFileInfo)] +getContactChatItemIdsAndFileInfo st userId contactId = + liftIO . withTransaction st $ \db -> + map toItemIdAndFileInfo + <$> DB.query + db + [sql| + SELECT i.chat_item_id, f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? + |] + (userId, contactId) + +getGroupChatItemIdsAndFileInfo :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m [(ChatItemId, Maybe CIFileInfo)] +getGroupChatItemIdsAndFileInfo st userId groupId = + liftIO . withTransaction st $ \db -> + map toItemIdAndFileInfo + <$> DB.query + db + [sql| + SELECT i.chat_item_id, f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE i.user_id = ? AND i.group_id = ? + |] + (userId, groupId) + +toItemIdAndFileInfo :: (ChatItemId, Maybe Int64, Maybe ACIFileStatus, Maybe FilePath) -> (ChatItemId, Maybe CIFileInfo) +toItemIdAndFileInfo (chatItemId, fileId_, fileStatus_, filePath) = + case (fileId_, fileStatus_) of + (Just fileId, Just fileStatus) -> (chatItemId, Just CIFileInfo {fileId, fileStatus, filePath}) + _ -> (chatItemId, Nothing) createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> m SndMessage createNewSndMessage st gVar connOrGroupId mkMessage = @@ -2449,8 +2488,8 @@ createNewSndChatItem st user chatDirection SndMessage {msgId, sharedMsgId} ciCon CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) -createNewRcvChatItem :: MonadUnliftIO m => SQLiteStore -> User -> ChatDirection c 'MDRcv -> RcvMessage -> CIContent 'MDRcv -> UTCTime -> UTCTime -> m (ChatItemId, Maybe (CIQuote c)) -createNewRcvChatItem st user chatDirection RcvMessage {msgId, chatMsgEvent, sharedMsgId_} ciContent itemTs createdAt = +createNewRcvChatItem :: MonadUnliftIO m => SQLiteStore -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> UTCTime -> UTCTime -> m (ChatItemId, Maybe (CIQuote c)) +createNewRcvChatItem st user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent itemTs createdAt = liftIO . withTransaction st $ \db -> do ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemTs createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg @@ -3229,13 +3268,39 @@ updateDirectChatItem_ db userId contactId itemId newContent currentTs = runExcep correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci -deleteDirectChatItemInternal :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> m AChatItem -deleteDirectChatItemInternal st userId ct itemId = +deleteDirectChatItemLocal :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> m AChatItem +deleteDirectChatItemLocal st userId ct itemId mode = liftIOEither . withTransaction st $ \db -> do - currentTs <- liftIO getCurrentTime - ci <- deleteDirectChatItem_ db userId ct itemId CIDMInternal True currentTs - setChatItemMessagesDeleted_ db itemId - pure ci + deleteChatItemMessages_ db itemId + deleteDirectChatItem_ db userId ct itemId mode + +deleteDirectChatItem_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> IO (Either StoreError AChatItem) +deleteDirectChatItem_ db userId ct@Contact {contactId} itemId mode = runExceptT $ do + (CChatItem msgDir ci) <- ExceptT $ 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}) + +deleteChatItemMessages_ :: DB.Connection -> ChatItemId -> IO () +deleteChatItemMessages_ db itemId = + DB.execute + db + [sql| + DELETE FROM messages + WHERE message_id IN ( + SELECT message_id + FROM chat_item_messages + WHERE chat_item_id = ? + ) + |] + (Only itemId) setChatItemMessagesDeleted_ :: DB.Connection -> ChatItemId -> IO () setChatItemMessagesDeleted_ db itemId = @@ -3256,38 +3321,26 @@ setChatItemMessagesDeleted_ db itemId = 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 + currentTs <- liftIO getCurrentTime + insertChatItemMessage_ db itemId msgId currentTs + updateDirectChatItemRcvDeleted_ db userId ct itemId currentTs -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 +updateDirectChatItemRcvDeleted_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> UTCTime -> IO (Either StoreError AChatItem) +updateDirectChatItemRcvDeleted_ db userId ct@Contact {contactId} itemId currentTs = runExceptT $ do (CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId - let toContent = msgDirToDeletedContent_ msgDir mode + let toContent = msgDirToDeletedContent_ msgDir CIDMBroadcast + toText = ciDeleteModeToText CIDMBroadcast liftIO $ do DB.execute db [sql| UPDATE chat_items - SET item_content = ?, item_text = ?, item_deleted = ?, updated_at = ? + SET item_content = ?, item_text = ?, 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 + (toContent, toText, currentTs, userId, contactId, itemId) + pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {content = toContent, meta = (meta ci) {itemText = toText}, formattedText = Nothing}) deleteQuote_ :: DB.Connection -> ChatItemId -> IO () deleteQuote_ db itemId = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 72d374a161..5283a607c1 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -54,6 +54,7 @@ responseToView testView = \case CRChatItemStatusUpdated _ -> [] CRChatItemUpdated (AChatItem _ _ chat item) -> viewItemUpdate chat item CRChatItemDeleted (AChatItem _ _ chat deletedItem) (AChatItem _ _ _ toItem) -> viewItemDelete chat deletedItem toItem + CRChatItemDeletedNotFound Contact {localDisplayName = c} _ -> [ttyFrom $ c <> "> [deleted - original message not found]"] CRBroadcastSent mc n ts -> viewSentBroadcast mc n ts CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr CRCmdAccepted _ -> [] @@ -83,6 +84,7 @@ responseToView testView = \case CRSentConfirmation -> ["confirmation sent!"] CRSentInvitation -> ["connection request sent!"] CRContactDeleted c -> [ttyContact' c <> ": contact is deleted"] + CRChatCleared chatInfo -> viewChatCleared chatInfo CRAcceptingContactRequest c -> [ttyFullContact c <> ": accepting contact request..."] CRContactAlreadyExists c -> [ttyFullContact c <> ": contact already exists"] CRContactRequestAlreadyAccepted c -> [ttyFullContact c <> ": sent you a duplicate contact request, but you are already connected, no action needed"] @@ -254,14 +256,12 @@ viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} ChatItem (CIDirectRcv, CIRcvMsgContent mc, CIRcvDeleted mode) -> case mode of CIDMBroadcast -> viewReceivedMessage (ttyFromContactDeleted c) [] mc meta CIDMInternal -> ["message deleted"] - (CIDirectSnd, _, _) -> ["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 meta CIDMInternal -> ["message deleted"] - (CIGroupSnd, _, _) -> ["message deleted"] - _ -> [] + _ -> ["message deleted"] _ -> [] directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString] @@ -315,6 +315,12 @@ viewConnReqInvitation cReq = "and ask them to connect: " <> highlight' "/c " ] +viewChatCleared :: AChatInfo -> [StyledString] +viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of + DirectChat ct -> [ttyContact' ct <> ": all messages are removed locally ONLY"] + GroupChat gi -> [ttyGroup' gi <> ": all messages are removed locally ONLY"] + _ -> [] + viewContactsList :: [Contact] -> [StyledString] viewContactsList = let ldn = T.toLower . (localDisplayName :: Contact -> ContactName) diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 254da1eb0a..8c53408e7c 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -130,6 +130,11 @@ testAddContact = alice <## "no contact bob_1" alice @@@ [("@bob", "hi")] bob @@@ [("@alice_1", "hi"), ("@alice", "hi")] + -- test clearing chat + alice #$> ("/clear bob", id, "bob: all messages are removed locally ONLY") + alice #$> ("/_get chat @2 count=100", chat, []) + bob #$> ("/clear alice", id, "alice: all messages are removed locally ONLY") + bob #$> ("/_get chat @2 count=100", chat, []) where chatsEmpty alice bob = do alice @@@ [("@bob", "")] @@ -241,49 +246,66 @@ testDirectMessageDelete = \alice bob -> do connectUsers alice bob - -- msg id 1 + -- alice, bob: msg id 1 alice #> "@bob hello 🙂" bob <# "alice> hello 🙂" - -- msg id 2 - bob `send` "> @alice (hello) hey alic" + -- alice, bob: msg id 2 + bob `send` "> @alice (hello 🙂) hey alic" bob <# "@alice > hello 🙂" bob <## " hey alic" alice <# "bob> > hello 🙂" alice <## " hey alic" + -- alice: deletes msg ids 1,2 alice #$> ("/_delete item @2 1 internal", id, "message deleted") alice #$> ("/_delete item @2 2 internal", id, "message deleted") alice @@@ [("@bob", "")] alice #$> ("/_get chat @2 count=100", chat, []) - alice #$> ("/_update item @2 1 text updating deleted message", id, "cannot update this item") - alice #$> ("/_send @2 json {\"quotedItemId\": 1, \"msgContent\": {\"type\": \"text\", \"text\": \"quoting deleted message\"}}", id, "cannot reply to this message") - + -- alice: msg id 1 bob #$> ("/_update item @2 2 text hey alice", id, "message updated") alice <# "bob> [edited] hey alice" - alice @@@ [("@bob", "hey alice")] alice #$> ("/_get chat @2 count=100", chat, [(0, "hey alice")]) - -- msg id 3 + -- bob: deletes msg id 2 + bob #$> ("/_delete item @2 2 broadcast", id, "message deleted") + alice <# "bob> [deleted] hey alice" + alice @@@ [("@bob", "this item is deleted (broadcast)")] + alice #$> ("/_get chat @2 count=100", chat, [(0, "this item is deleted (broadcast)")]) + + -- alice: deletes msg id 1 that was broadcast deleted by bob + alice #$> ("/_delete item @2 1 internal", id, "message deleted") + alice @@@ [("@bob", "")] + alice #$> ("/_get chat @2 count=100", chat, []) + + -- alice: msg id 1, bob: msg id 2 (quoting message alice deleted locally) + bob `send` "> @alice (hello 🙂) do you receive my messages?" + bob <# "@alice > hello 🙂" + bob <## " do you receive my messages?" + alice <# "bob> > hello 🙂" + alice <## " do you receive my messages?" + alice @@@ [("@bob", "do you receive my messages?")] + alice #$> ("/_get chat @2 count=100", chat', [((0, "do you receive my messages?"), Just (1, "hello 🙂"))]) + alice #$> ("/_delete item @2 1 broadcast", id, "cannot delete this item") + + -- alice: msg id 2, bob: msg id 3 bob #> "@alice how are you?" alice <# "bob> how are you?" - bob #$> ("/_delete item @2 3 broadcast", id, "message deleted") - alice <# "bob> [deleted] how are you?" - - alice #$> ("/_delete item @2 1 broadcast", id, "message deleted") - bob <# "alice> [deleted] hello 🙂" - - alice #$> ("/_delete item @2 2 broadcast", id, "cannot delete this item") + -- alice: deletes msg id 2 alice #$> ("/_delete item @2 2 internal", id, "message deleted") - alice @@@ [("@bob", "this item is deleted (broadcast)")] - alice #$> ("/_get chat @2 count=100", chat, [(0, "this item is deleted (broadcast)")]) - bob @@@ [("@alice", "hey alice")] - bob #$> ("/_get chat @2 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hey alice"), (Just (0, "hello 🙂")))]) + -- bob: deletes msg id 3 (that alice deleted locally) + bob #$> ("/_delete item @2 3 broadcast", id, "message deleted") + alice <## "bob> [deleted - original message not found]" + + alice @@@ [("@bob", "do you receive my messages?")] + alice #$> ("/_get chat @2 count=100", chat', [((0, "do you receive my messages?"), Just (1, "hello 🙂"))]) + bob @@@ [("@alice", "do you receive my messages?")] + bob #$> ("/_get chat @2 count=100", chat', [((0, "hello 🙂"), Nothing), ((1, "do you receive my messages?"), Just (0, "hello 🙂"))]) testGroup :: IO () testGroup = @@ -372,6 +394,13 @@ testGroup = cath ##> "#team hello" cath <## "you are no longer a member of the group" bob <##> cath + -- test clearing chat + alice #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") + alice #$> ("/_get chat #1 count=100", chat, []) + bob #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") + bob #$> ("/_get chat #1 count=100", chat, []) + cath #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") + cath #$> ("/_get chat #1 count=100", chat, []) where getReadChats alice bob cath = do alice @@@ [("#team", "hey team"), ("@cath", ""), ("@bob", "")]