From 73638129bcee25100d9c033d52f4f2a2bff6060d Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 3 Apr 2023 18:49:22 +0400 Subject: [PATCH] core: cancel file transfer when chat item is marked deleted (#2137) --- src/Simplex/Chat.hs | 89 ++++++++++++++++++++++++------------ src/Simplex/Chat/Messages.hs | 3 ++ src/Simplex/Chat/Store.hs | 25 ++++++---- tests/ChatTests/Files.hs | 64 +++++++++++++++++++++++++- 4 files changed, 140 insertions(+), 41 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 2e41f31ea..c40f6bc20 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 8040ea942..ad2bf2f8c 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index e5efbfc88..84e5b8f8a 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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 diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 200daeb29..1a4670777 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -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 [/ | ] 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 [/ | ] 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"