From 2058e904e60f96c2e1c4398bc450b68176736f1c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 15 Apr 2022 13:16:34 +0100 Subject: [PATCH] core: refactor files folder support (#532) Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- src/Simplex/Chat.hs | 116 ++++++++++++++++++++----------------- src/Simplex/Chat/Mobile.hs | 1 - src/Simplex/Chat/Store.hs | 4 +- tests/ChatTests.hs | 92 ++++++++++++++++++++++++----- 4 files changed, 143 insertions(+), 70 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 764170f276..49c915aeb6 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -64,7 +64,7 @@ import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) import Text.Read (readMaybe) import UnliftIO.Async import UnliftIO.Concurrent (forkIO, threadDelay) -import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory, removeFile, removePathForcibly) +import UnliftIO.Directory import qualified UnliftIO.Exception as E import UnliftIO.IO (hClose, hSeek, hTell) import UnliftIO.STM @@ -173,7 +173,7 @@ processChatCommand = \case asks agentAsync >>= readTVarIO >>= \case Just _ -> pure CRChatRunning _ -> startChatController user $> CRChatStarted - SetFilesFolder filesFolder' -> withUser' $ \_ -> do + SetFilesFolder filesFolder' -> withUser $ \_ -> do createDirectoryIfMissing True filesFolder' ff <- asks filesFolder atomically . writeTVar ff $ Just filesFolder' @@ -300,12 +300,12 @@ processChatCommand = \case (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do - deleteFile file + deleteFile userId file toCi <- withStore $ \st -> deleteDirectChatItemInternal st userId ct itemId pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendDirectContactMessage ct (XMsgDel itemSharedMId) - deleteFile file + deleteFile userId file toCi <- withStore $ \st -> deleteDirectChatItemSndBroadcast st userId ct itemId msgId setActive $ ActiveC c pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi @@ -313,22 +313,27 @@ processChatCommand = \case CTGroup -> do Group gInfo@GroupInfo {localDisplayName = gName, membership} ms <- withStore $ \st -> getGroup st user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved - CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}} <- withStore $ \st -> getGroupChatItem st user chatId itemId + CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file} <- withStore $ \st -> getGroupChatItem st user chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do + deleteFile userId file toCi <- withStore $ \st -> deleteGroupChatItemInternal st user gInfo itemId pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId) + deleteFile userId file toCi <- withStore $ \st -> deleteGroupChatItemSndBroadcast st user gInfo itemId msgId setActive $ ActiveG gName pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete CTContactRequest -> pure $ chatCmdError "not supported" where - deleteFile :: MsgDirectionI d => Maybe (CIFile d) -> m () - deleteFile (Just CIFile {fileId, filePath, fileStatus}) = deleteFiles [(fileId, filePath, AFS msgDirection fileStatus)] - deleteFile Nothing = pure () + deleteFile :: MsgDirectionI d => UserId -> Maybe (CIFile d) -> m () + deleteFile userId file = + forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do + cancelFiles userId [(fileId, AFS msgDirection fileStatus)] + withFilesFolder $ \filesFolder -> + deleteFiles filesFolder [filePath] APIChatRead cType chatId fromToIds -> withChatLock $ case cType of CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk CTGroup -> withStore (\st -> updateGroupChatItemsRead st chatId fromToIds) $> CRCmdOk @@ -341,7 +346,9 @@ processChatCommand = \case files <- withStore $ \st -> getContactFiles st userId ct conns <- withStore $ \st -> getContactConnections st userId ct withChatLock . procCmd $ do - deleteFiles files + cancelFiles userId (map (\(fId, fStatus, _) -> (fId, fStatus)) files) + withFilesFolder $ \filesFolder -> do + deleteFiles filesFolder (map (\(_, _, fPath) -> fPath) files) withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () withStore $ \st -> deleteContact st userId ct @@ -592,24 +599,8 @@ processChatCommand = \case ChatErrorAgent (CONN DUPLICATE) -> pure $ CRRcvFileAcceptedSndCancelled ft e -> throwError e CancelFile fileId -> withUser $ \User {userId} -> do - ft' <- withStore (\st -> getFileTransfer st userId fileId) - withChatLock . procCmd $ do - case ft' of - FTSnd ftm fts -> do - cancelFileTransfer userId ft' CIFSSndCancelled - forM_ fts $ \ft -> cancelSndFileTransfer ft - pure $ CRSndGroupFileCancelled ftm fts - FTRcv ft -> do - cancelFileTransfer userId ft' CIFSRcvCancelled - cancelRcvFileTransfer ft - pure $ CRRcvFileCancelled ft - where - cancelFileTransfer :: MsgDirectionI d => UserId -> FileTransfer -> CIFileStatus d -> m () - cancelFileTransfer userId ft ciFileStatus = - unless (fileTransferCancelled ft) $ - withStore $ \st -> do - updateFileCancelled st userId fileId - updateCIFileStatus st userId fileId ciFileStatus + ft <- withStore (\st -> getFileTransfer st userId fileId) + withChatLock . procCmd $ cancelFile userId fileId ft FileStatus fileId -> CRFileTransferStatus <$> withUser (\User {userId} -> withStore $ \st -> getFileTransferProgress st userId fileId) ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile @@ -674,33 +665,53 @@ processChatCommand = \case isReady ct = let s = connStatus $ activeConn (ct :: Contact) in s == ConnReady || s == ConnSndReady + -- 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 :: UserId -> [(Int64, ACIFileStatus)] -> m () + cancelFiles userId files = + forM_ files $ \(fileId, status) -> do + case status of + AFS _ CIFSSndStored -> cancelById fileId + AFS _ CIFSRcvInvitation -> cancelById fileId + AFS _ CIFSRcvTransfer -> cancelById fileId + _ -> pure () + where + cancelById fileId = do + ft <- withStore (\st -> getFileTransfer st userId fileId) + void $ cancelFile userId fileId ft + cancelFile :: UserId -> Int64 -> FileTransfer -> m ChatResponse + cancelFile userId fileId ft = + case ft of + FTSnd ftm fts -> do + cancelFileTransfer CIFSSndCancelled + forM_ fts $ \ft' -> cancelSndFileTransfer ft' + pure $ CRSndGroupFileCancelled ftm fts + FTRcv ftr -> do + cancelFileTransfer CIFSRcvCancelled + cancelRcvFileTransfer ftr + pure $ CRRcvFileCancelled ftr + where + cancelFileTransfer :: MsgDirectionI d => CIFileStatus d -> m () + cancelFileTransfer ciFileStatus = + unless (fileTransferCancelled ft) $ + withStore $ \st -> do + updateFileCancelled st userId fileId + updateCIFileStatus st userId fileId ciFileStatus -- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), -- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path -- used during file transfer for actual operations with file system toFSFilePath :: ChatMonad m => FilePath -> m FilePath -toFSFilePath f = do - ff <- asks filesFolder - readTVarIO ff >>= \case - Nothing -> pure f - Just filesFolder -> pure $ filesFolder <> "/" <> f - -deleteFiles :: ChatMonad m => [(Int64, Maybe FilePath, ACIFileStatus)] -> m () -deleteFiles files = do - ff <- asks filesFolder - readTVarIO ff >>= \case - Nothing -> pure () -- only delete files if filesFolder is set (i.e. on mobile devices) - Just filesFolder -> - forM_ files $ \(fileId, filePath_, status) -> do - case status of - AFS _ CIFSRcvTransfer -> closeFileHandle fileId rcvFiles - _ -> pure () - case filePath_ of - Just filePath -> do - let fsFilePath = filesFolder <> "/" <> filePath - removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> - removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () - Nothing -> pure () +toFSFilePath f = + maybe f (<> "/" <> f) <$> (readTVarIO =<< asks filesFolder) acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe FilePath -> m FilePath acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq}, fileStatus, senderDisplayName, grpMemberId} filePath_ = do @@ -738,9 +749,8 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F where getRcvFilePath :: Maybe FilePath -> String -> m FilePath getRcvFilePath fPath_ fn = case fPath_ of - Nothing -> do - ff <- asks filesFolder - readTVarIO ff >>= \case + Nothing -> + asks filesFolder >>= readTVarIO >>= \case Nothing -> do dir <- (`combine` "Downloads") <$> getHomeDirectory ifM (doesDirectoryExist dir) (pure dir) getTemporaryDirectory @@ -1289,7 +1299,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId case msgDir of SMDRcv -> do - -- TODO either allow to locally delete items that were broadcast deleted by sender, or delete attached files + -- 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 checkIntegrity msgMeta $ toView . CRMsgIntegrityError diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 64d6587834..b830860ef5 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Simplex.Chat.Mobile where diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index ba2219bf4d..bb10843521 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -2216,13 +2216,13 @@ 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, Maybe FilePath, ACIFileStatus)] +getContactFiles :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [(Int64, ACIFileStatus, Maybe FilePath)] getContactFiles st userId Contact {contactId} = liftIO . withTransaction st $ \db -> DB.query db [sql| - SELECT f.file_id, f.file_path, f.ci_file_status + 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 = ? diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 7abf2f6b56..dc49a12808 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -15,7 +15,7 @@ import qualified Data.Text as T import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Types (ImageData (..), Profile (..), User (..)) import Simplex.Chat.Util (unlessM) -import System.Directory (doesFileExist) +import System.Directory (copyFile, doesFileExist) import Test.Hspec aliceProfile :: Profile @@ -66,7 +66,9 @@ chatTests = do describe "messages with files" $ do it "send and receive message with file" testMessageWithFile it "send and receive image" testSendImage - it "send and receive image with files folders (for mobile)" testSendImageWithFilesFolders + 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 it "send and receive image with text and quote" testSendImageWithTextAndQuote it "send and receive image to group" testGroupSendImage it "send and receive image with text and quote to group" testGroupSendImageWithTextAndQuote @@ -1038,8 +1040,6 @@ testFileRcvCancel = alice <## "sending file 1 (test.jpg) cancelled: bob" ] checkPartialTransfer - where - waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f testGroupFileTransfer :: IO () testGroupFileTransfer = @@ -1167,8 +1167,6 @@ testFileRcvCancelV2 = alice <## "sending file 1 (test.jpg) cancelled: bob" ] checkPartialTransfer - where - waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f testGroupFileTransferV2 :: IO () testGroupFileTransferV2 = @@ -1268,13 +1266,13 @@ testSendImage = fileExists <- doesFileExist "./tests/tmp/test.jpg" fileExists `shouldBe` True -testSendImageWithFilesFolders :: IO () -testSendImageWithFilesFolders = +testFilesFoldersSendImage :: IO () +testFilesFoldersSendImage = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob alice #$> ("/_files_folder ./tests/fixtures", id, "ok") - bob #$> ("/_files_folder ./tests/tmp", id, "ok") + bob #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") alice ##> "/_send @2 file test.jpg json {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" @@ -1289,15 +1287,70 @@ testSendImageWithFilesFolders = (bob <## "completed receiving file 1 (test.jpg) from alice") (alice <## "completed sending file 1 (test.jpg) to bob") src <- B.readFile "./tests/fixtures/test.jpg" - dest <- B.readFile "./tests/tmp/test.jpg" + dest <- B.readFile "./tests/tmp/app_files/test.jpg" dest `shouldBe` src alice #$> ("/_get chat @2 count=100", chatF, [((1, ""), Just "test.jpg")]) bob #$> ("/_get chat @2 count=100", chatF, [((0, ""), Just "test.jpg")]) -- deleting contact with files folder set should remove file - bob ##> "/d alice" - bob <## "alice: contact is deleted" - fileExists <- doesFileExist "./tests/tmp/test.jpg" - fileExists `shouldBe` False + checkActionDeletesFile "./tests/tmp/app_files/test.jpg" $ do + bob ##> "/d alice" + bob <## "alice: contact is deleted" + +testFilesFoldersImageSndDelete :: IO () +testFilesFoldersImageSndDelete = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") + copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg" + bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok") + alice ##> "/_send @2 file test.jpg json {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}" + alice <# "/f @bob test.jpg" + alice <## "use /fc 1 to cancel sending" + bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + bob ##> "/fr 1" + bob <## "saving file 1 from alice to test.jpg" + concurrently_ + (bob <## "started receiving file 1 (test.jpg) from alice") + (alice <## "started sending file 1 (test.jpg) to bob") + -- deleting contact should cancel and remove file + checkActionDeletesFile "./tests/tmp/alice_app_files/test.jpg" $ do + alice ##> "/d bob" + alice <## "bob: contact is deleted" + bob <## "alice cancelled sending file 1 (test.jpg)" + bob ##> "/fs 1" + bob <## "receiving file 1 (test.jpg) cancelled, received part path: test.jpg" + -- deleting contact should remove cancelled file + checkActionDeletesFile "./tests/tmp/bob_app_files/test.jpg" $ do + bob ##> "/d alice" + bob <## "alice: contact is deleted" + +testFilesFoldersImageRcvDelete :: IO () +testFilesFoldersImageRcvDelete = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + alice #$> ("/_files_folder ./tests/fixtures", id, "ok") + bob #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") + alice ##> "/_send @2 file test.jpg json {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}" + alice <# "/f @bob test.jpg" + alice <## "use /fc 1 to cancel sending" + bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + bob ##> "/fr 1" + bob <## "saving file 1 from alice to test.jpg" + concurrently_ + (bob <## "started receiving file 1 (test.jpg) from alice") + (alice <## "started sending file 1 (test.jpg) to bob") + -- deleting contact should cancel and remove file + waitFileExists "./tests/tmp/app_files/test.jpg" + checkActionDeletesFile "./tests/tmp/app_files/test.jpg" $ do + bob ##> "/d alice" + bob <## "alice: contact is deleted" + alice <## "bob cancelled receiving file 1 (test.jpg)" + alice ##> "/fs 1" + alice <## "sending file 1 (test.jpg) cancelled: bob" testSendImageWithTextAndQuote :: IO () testSendImageWithTextAndQuote = @@ -1709,6 +1762,17 @@ checkPartialTransfer = do B.unpack src `shouldStartWith` B.unpack dest B.length src > B.length dest `shouldBe` True +checkActionDeletesFile :: FilePath -> IO () -> IO () +checkActionDeletesFile file action = do + fileExistsBefore <- doesFileExist file + fileExistsBefore `shouldBe` True + action + fileExistsAfter <- doesFileExist file + fileExistsAfter `shouldBe` False + +waitFileExists :: FilePath -> IO () +waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f + connectUsers :: TestCC -> TestCC -> IO () connectUsers cc1 cc2 = do name1 <- showName cc1