dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-25 14:14:39 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: refactor files folder support (#532)

Browse Source 
Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2022-04-15 13:16:34 +01:00
committed by GitHub
parent e560ed8327
commit 2058e904e6
4 changed files with 143 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+63 -53
View File
@@ -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
src/Simplex/Chat/Mobile.hs
-1
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Mobile where
src/Simplex/Chat/Store.hs
+2 -2
View File
@@ -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 = ?
tests/ChatTests.hs
+78 -14
View File
@@ -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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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