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

core: cancel file transfer when chat item is marked deleted (#2137)

Browse Source
This commit is contained in:
spaced4ndy 2023-04-03 18:49:22 +04:00 committed by GitHub
parent 1a7a79d504
commit 73638129bc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 140 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
src/Simplex/Chat.hs
View File

@ -1801,12 +1801,26 @@ deleteFile :: forall m. ChatMonad m => User -> CIFileInfo -> m [ConnId]
deleteFile user fileInfo = deleteFile' user fileInfo False
deleteFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
deleteFile' user CIFileInfo {filePath, fileId, fileStatus} sendCancel = do
aConnIds <- case fileStatus of
Just fStatus -> cancel' fStatus `catchError` (\e -> toView (CRChatError (Just user) e) $> [])
Nothing -> pure []
deleteFile' user ciFileInfo@CIFileInfo {filePath} sendCancel = do
aConnIds <- cancelFile' user ciFileInfo sendCancel
delete `catchError` (toView . CRChatError (Just user))
pure aConnIds
where
delete :: m ()
delete = withFilesFolder $ \filesFolder ->
forM_ filePath $ \fPath -> do
let fsFilePath = filesFolder </> fPath
removeFile fsFilePath `E.catch` \(_ :: E.SomeException) ->
removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure ()
-- perform an action only if filesFolder is set (i.e. on mobile devices)
withFilesFolder :: (FilePath -> m ()) -> m ()
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
cancelFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
cancelFile' user CIFileInfo {fileId, fileStatus} sendCancel =
case fileStatus of
Just fStatus -> cancel' fStatus `catchError` (\e -> toView (CRChatError (Just user) e) $> [])
Nothing -> pure []
where
cancel' :: ACIFileStatus -> m [ConnId]
cancel' (AFS dir status) =
@ -1819,15 +1833,6 @@ deleteFile' user CIFileInfo {filePath, fileId, fileStatus} sendCancel = do
SMDRcv -> do
ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId)
if cancelled then pure [] else maybeToList <$> cancelRcvFileTransfer user ft
delete :: m ()
delete = withFilesFolder $ \filesFolder ->
forM_ filePath $ \fPath -> do
let fsFilePath = filesFolder </> fPath
removeFile fsFilePath `E.catch` \(_ :: E.SomeException) ->
removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure ()
-- perform an action only if filesFolder is set (i.e. on mobile devices)
withFilesFolder :: (FilePath -> m ()) -> m ()
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
updateCallItemStatus :: ChatMonad m => User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> m ()
updateCallItemStatus user ct Call {chatItemId} receivedStatus msgId_ = do
@ -1887,10 +1892,15 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
filePath <- getRcvFilePath fileId filePath_ fName True
withStore $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
-- XFTP
(Just XFTPRcvFile {rcvFileDescription}, _) -> do
(Just _xftpRcvFile, _) -> do
filePath <- getRcvFilePath fileId filePath_ fName False
ci <- withStore $ \db -> xftpAcceptRcvFT db user fileId filePath
receiveViaCompleteFD user fileId rcvFileDescription
(ci, rfd) <- withStore $ \db -> do
-- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db user fileId filePath
rfd <- getRcvFileDescrByFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd
pure ci
-- group & direct file protocol
_ -> do
@ -3079,13 +3089,17 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processFDMessage :: FileTransferId -> FileDescr -> m ()
processFDMessage fileId fileDescr = do
(rfd, RcvFileTransfer {fileStatus}) <- withStore $ \db -> do
rfd <- appendRcvFD db userId fileId fileDescr
ft <- getRcvFileTransfer db user fileId
pure (rfd, ft)
case fileStatus of
RFSAccepted _ -> receiveViaCompleteFD user fileId rfd
_ -> pure ()
RcvFileTransfer {cancelled} <- withStore $ \db -> getRcvFileTransfer db user fileId
unless cancelled $ do
(rfd, RcvFileTransfer {fileStatus}) <- withStore $ \db -> do
rfd <- appendRcvFD db userId fileId fileDescr
-- reading second time in the same transaction as appending description
-- to prevent race condition with accept
ft <- getRcvFileTransfer db user fileId
pure (rfd, ft)
case fileStatus of
RFSAccepted _ -> receiveViaCompleteFD user fileId rfd
_ -> pure ()
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
cancelMessageFile ct _sharedMsgId msgMeta = do
@ -4093,14 +4107,31 @@ deleteCIFile user file =
deleteAgentConnectionsAsync user fileAgentConnIds
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> m ChatResponse
markDirectCIDeleted user ct ci@(CChatItem msgDir deletedItem) msgId byUser = do
toCi <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) (Just toCi) byUser False
markDirectCIDeleted user ct@Contact {contactId} ci@(CChatItem _ ChatItem {file}) msgId byUser = do
cancelCIFile user file
toCi <- withStore $ \db -> do
liftIO $ markDirectChatItemDeleted db user ct ci msgId
getDirectChatItem db user contactId (cchatItemId ci)
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem toCi) byUser False
where
ctItem (CChatItem msgDir ci') = AChatItem SCTDirect msgDir (DirectChat ct) ci'
markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> Maybe GroupMember -> m ChatResponse
markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser byGroupMember_ = do
toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) (Just toCi) byUser False
markGroupCIDeleted user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file}) msgId byUser byGroupMember_ = do
cancelCIFile user file
toCi <- withStore $ \db -> do
liftIO $ markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_
getGroupChatItem db user groupId (cchatItemId ci)
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem toCi) byUser False
where
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci'
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
cancelCIFile user file =
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
fileAgentConnIds <- cancelFile' user fileInfo True
deleteAgentConnectionsAsync user fileAgentConnIds
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
createAgentConnectionAsync user cmdFunction enableNtfs cMode = do

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

@ -179,6 +179,9 @@ instance ToJSON (CChatItem c) where
toJSON (CChatItem _ ci) = J.toJSON ci
toEncoding (CChatItem _ ci) = J.toEncoding ci
cchatItemId :: CChatItem c -> ChatItemId
cchatItemId (CChatItem _ ci) = chatItemId' ci
chatItemId' :: ChatItem c d -> ChatItemId
chatItemId' ChatItem {meta = CIMeta {itemId}} = itemId

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

@ -178,6 +178,7 @@ module Simplex.Chat.Store
createRcvFileTransfer,
createRcvGroupFileTransfer,
appendRcvFD,
getRcvFileDescrByFileId,
updateRcvFileAgentId,
getRcvFileTransferById,
getRcvFileTransfer,
@ -2781,7 +2782,6 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId})
<$> (contactName_ <|> memberName_)
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
currentTs <- getCurrentTime
@ -3056,6 +3056,12 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD
(fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId)
pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete}
getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByFileId db fileId = do
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrByFileId_ db fileId =
maybeFirstRow toRcvFileDescr $
@ -4287,8 +4293,8 @@ deleteChatItemMessages_ db itemId =
|]
(Only itemId)
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> IO AChatItem
markDirectChatItemDeleted db User {userId} ct@Contact {contactId} (CChatItem msgDir ci) msgId = do
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> IO ()
markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId = do
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs
@ -4300,7 +4306,6 @@ markDirectChatItemDeleted db User {userId} ct@Contact {contactId} (CChatItem msg
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|]
(currentTs, userId, contactId, itemId)
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {meta = (meta ci) {itemDeleted = Just (CIDeleted @'CTDirect), editable = False}})
getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do
@ -4417,13 +4422,13 @@ updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatIt
(groupMemberId, toContent, toText, currentTs, userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated m)}, formattedText = Nothing})
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> IO AChatItem
markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId byGroupMember_ = do
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> IO ()
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ = do
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
(deletedByGroupMemberId, ciDeleted) = case byGroupMember_ of
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, CIModerated m)
_ -> (Nothing, CIDeleted)
deletedByGroupMemberId = case byGroupMember_ of
Just GroupMember {groupMemberId} -> Just groupMemberId
_ -> Nothing
insertChatItemMessage_ db itemId msgId currentTs
DB.execute
db
@ -4433,7 +4438,6 @@ markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem m
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(deletedByGroupMemberId, currentTs, userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = Just ciDeleted, editable = False}})
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do
@ -5201,6 +5205,7 @@ data StoreError
| SESndFileNotFound {fileId :: FileTransferId}
| SESndFileInvalid {fileId :: FileTransferId}
| SERcvFileNotFound {fileId :: FileTransferId}
| SERcvFileDescrNotFound {fileId :: FileTransferId}
| SEFileNotFound {fileId :: FileTransferId}
| SERcvFileInvalid {fileId :: FileTransferId}
| SERcvFileInvalidDescrPart

64
tests/ChatTests/Files.hs
View File

@ -38,6 +38,7 @@ chatFileTests = do
describe "messages with files" $ do
describe "send and receive message with file" $ fileTestMatrix2 runTestMessageWithFile
it "send and receive image" testSendImage
it "sender marking chat item deleted during file transfer cancels file" testSenderMarkItemDeletedTransfer
it "files folder: send and receive image" testFilesFoldersSendImage
it "files folder: sender deleted file during transfer" testFilesFoldersImageSndDelete
it "files folder: recipient deleted file during transfer" testFilesFoldersImageRcvDelete
@ -53,6 +54,7 @@ chatFileTests = do
xit "send and receive file to group, fully asynchronous" testAsyncGroupFileTransfer
describe "file transfer over XFTP" $ do
it "send and receive file" testXFTPFileTransfer
it "send and receive file, accepting after upload" testXFTPAcceptAfterUpload
it "send and receive file in group" testXFTPGroupFileTransfer
it "with changed XFTP config: send and receive file" testXFTPWithChangedConfig
it "with relative paths: send and receive file" testXFTPWithRelativePaths
@ -527,6 +529,36 @@ testSendImage =
fileExists <- doesFileExist "./tests/tmp/test.jpg"
fileExists `shouldBe` True
testSenderMarkItemDeletedTransfer :: HasCallStack => FilePath -> IO ()
testSenderMarkItemDeletedTransfer =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test_1MB.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}"
alice <# "@bob hi, sending a file"
alice <# "/f @bob ./tests/fixtures/test_1MB.pdf"
alice <## "use /fc 1 to cancel sending"
bob <# "alice> hi, sending a file"
bob <# "alice> sends file test_1MB.pdf (1017.7 KiB / 1042157 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob ##> "/fr 1 ./tests/tmp"
bob <## "saving file 1 from alice to ./tests/tmp/test_1MB.pdf"
concurrently_
(bob <## "started receiving file 1 (test_1MB.pdf) from alice")
(alice <## "started sending file 1 (test_1MB.pdf) to bob")
alice #$> ("/_delete item @2 " <> itemId 1 <> " broadcast", id, "message marked deleted")
alice ##> "/fs 1"
alice <## "sending file 1 (test_1MB.pdf) cancelled: bob"
alice <## "file transfer cancelled"
bob <# "alice> [marked deleted] hi, sending a file"
bob ##> "/fs 1"
bob <## "receiving file 1 (test_1MB.pdf) cancelled, received part path: ./tests/tmp/test_1MB.pdf"
checkPartialTransfer "test_1MB.pdf"
testFilesFoldersSendImage :: HasCallStack => FilePath -> IO ()
testFilesFoldersSendImage =
testChat2 aliceProfile bobProfile $
@ -950,6 +982,32 @@ testXFTPFileTransfer =
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testXFTPAcceptAfterUpload :: HasCallStack => FilePath -> IO ()
testXFTPAcceptAfterUpload =
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
withXFTPServer $ do
connectUsers alice bob
alice #> "/f @bob ./tests/fixtures/test.pdf"
alice <## "use /fc 1 to cancel sending"
bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
-- alice <## "started sending file 1 (test.pdf) to bob" -- TODO "started uploading" ?
alice <## "uploaded file 1 (test.pdf) for bob"
threadDelay 100000
bob ##> "/fr 1 ./tests/tmp"
bob <## "started receiving file 1 (test.pdf) from alice"
bob <## "saving file 1 from alice to ./tests/tmp/test.pdf"
bob <## "completed receiving file 1 (test.pdf) from alice"
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test.pdf"
dest `shouldBe` src
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testXFTPGroupFileTransfer :: HasCallStack => FilePath -> IO ()
testXFTPGroupFileTransfer =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
@ -1114,8 +1172,10 @@ testXFTPCancelRcvRepeat =
bob <## "cancelled receiving file 1 (testfile) from alice"
bob ##> "/fr 1 ./tests/tmp"
bob <## "started receiving file 1 (testfile) from alice"
bob <## "saving file 1 from alice to ./tests/tmp/testfile_1"
bob
<### [ "saving file 1 from alice to ./tests/tmp/testfile_1",
"started receiving file 1 (testfile) from alice"
]
bob <## "completed receiving file 1 (testfile) from alice"
src <- B.readFile "./tests/tmp/testfile"