mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-29 03:18:37 +00:00
core: fully delete direct chat items; clear chat API (#658)
This commit is contained in:
JRoberts
+85
-34
@@ -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)
|
||||
|
||||
@@ -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}
|
||||
|
||||
@@ -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
|
||||
|
||||
+92
-39
@@ -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 =
|
||||
|
||||
@@ -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 <invitation_link_above>"
|
||||
]
|
||||
|
||||
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)
|
||||
|
||||
+48
-19
@@ -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", "")]
|
||||
|
||||
Reference in New Issue
Block a user