From db120b6d2eee04836a132f0bfbca9491cacf3dc8 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Tue, 14 Mar 2023 19:16:25 +0400 Subject: [PATCH] xftp: pass save path to agent (#685) --- package.yaml | 1 + simplexmq.cabal | 1 + src/Simplex/FileTransfer/Agent.hs | 36 ++++++++++--------- src/Simplex/FileTransfer/Client.hs | 2 +- src/Simplex/FileTransfer/Types.hs | 3 +- src/Simplex/Messaging/Agent.hs | 4 +-- src/Simplex/Messaging/Agent/Protocol.hs | 8 ++--- src/Simplex/Messaging/Agent/Store/SQLite.hs | 26 ++++++-------- .../SQLite/Migrations/M20230223_files.hs | 3 +- .../Store/SQLite/Migrations/agent_schema.sql | 3 +- tests/AgentTests/SchemaDump.hs | 3 +- tests/XFTPAgent.hs | 32 +++++++++++------ 12 files changed, 65 insertions(+), 57 deletions(-) diff --git a/package.yaml b/package.yaml index 86e2d70be..eb10dac51 100644 --- a/package.yaml +++ b/package.yaml @@ -135,6 +135,7 @@ tests: main: Test.hs dependencies: - simplexmq + - deepseq == 1.4.* - hspec == 2.7.* - hspec-core == 2.7.* - HUnit == 1.6.* diff --git a/simplexmq.cabal b/simplexmq.cabal index 422ea01e8..dad233141 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -554,6 +554,7 @@ test-suite simplexmq-test , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* + , deepseq ==1.4.* , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 54a266608..b485f2844 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -58,13 +58,13 @@ import UnliftIO.Concurrent import UnliftIO.Directory import qualified UnliftIO.Exception as E -receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId -receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath = do +receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> FilePath -> m RcvFileId +receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath savePath = do g <- asks idsDrg workPath <- maybe getTemporaryDirectory pure xftpWorkPath encPath <- uniqueCombine workPath "xftp.encrypted" createDirectory encPath - fId <- withStore c $ \db -> createRcvFile db g userId fd workPath encPath + fId <- withStore c $ \db -> createRcvFile db g userId fd encPath savePath forM_ chunks downloadChunk pure fId where @@ -167,18 +167,22 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do decryptFile f `catchError` (workerInternalError c rcvFileId rcvFileEntityId tmpPath . show) noWorkToDo = void . atomically $ tryTakeTMVar doWork decryptFile :: RcvFile -> m () - decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveDir, savePath, chunks} = do - forM_ savePath $ \p -> do - removePath p - withStore' c (`updateRcvFileNoSavePath` rcvFileId) + decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, chunks} = do + -- TODO test; recreate file if it's in status RFSDecrypting + -- when (status == RFSDecrypting) $ + -- whenM (doesFileExist savePath) (removeFile savePath >> emptyFile) withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting chunkPaths <- getChunkPaths chunks encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths - path <- decrypt encSize chunkPaths + decrypt encSize chunkPaths forM_ tmpPath removePath - withStore' c $ \db -> updateRcvFileComplete db rcvFileId path - notify $ RFDONE path + withStore' c (`updateRcvFileComplete` rcvFileId) + notify RFDONE where + -- emptyFile :: m () + -- emptyFile = do + -- h <- openFile savePath AppendMode + -- liftIO $ B.hPut h "" >> hFlush h notify :: forall e. AEntityI e => ACommand 'Agent e -> m () notify cmd = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC (sAEntity @e) cmd) getChunkPaths :: [RcvFileChunk] -> m [FilePath] @@ -189,7 +193,7 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) = throwError $ INTERNAL "no chunk path" -- TODO refactor with decrypt in CLI, streaming decryption - decrypt :: Int64 -> [FilePath] -> m FilePath + decrypt :: Int64 -> [FilePath] -> m () decrypt encSize chunkPaths = do lazyChunks <- liftIO $ readChunks chunkPaths (authOk, f) <- liftEither . first cryptoError $ LC.sbDecryptTailTag key nonce (encSize - authTagSize) lazyChunks @@ -200,14 +204,12 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do -- TODO XFTP errors A.Fail _ _ e -> throwError $ INTERNAL $ "Invalid file header: " <> e A.Partial _ -> throwError $ INTERNAL "Invalid file header" - A.Done rest FileHeader {fileName} -> do - -- TODO touch file in agent bracket - path <- uniqueCombine saveDir fileName - liftIO $ LB.writeFile path $ LB.fromStrict rest <> f' + A.Done rest FileHeader {fileName = _fn} -> do + -- ? check file name match + liftIO $ LB.writeFile savePath $ LB.fromStrict rest <> f' unless authOk $ do - removeFile path + removeFile savePath throwError $ INTERNAL "Error decrypting file: incorrect auth tag" - pure path readChunks :: [FilePath] -> IO LB.ByteString readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) "" diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index d46971d64..a98248c03 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -174,7 +174,7 @@ downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChu downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do (rDhKey, rpDhKey) <- liftIO C.generateKeyPair' sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case - (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of + (FRFile sDhKey cbNonce, HTTP2Body {bodyHead = _bg, bodySize = _bs, bodyPart}) -> case bodyPart of -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set Just chunkPart -> do let dhSecret = C.dh' sDhKey rpDhKey diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index da673f4c9..c9f5aa7ae 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -47,8 +47,7 @@ data RcvFile = RcvFile chunkSize :: FileSize Word32, chunks :: [RcvFileChunk], tmpPath :: Maybe FilePath, - saveDir :: FilePath, - savePath :: Maybe FilePath, + savePath :: FilePath, status :: RcvFileStatus } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 15ba9fb67..a1d80b93f 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -339,8 +339,8 @@ toggleConnectionNtfs :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c -- | Receive XFTP file -xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId -xftpReceiveFile c = withAgentEnv c .:. receiveFile c +xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> FilePath -> m RcvFileId +xftpReceiveFile c = withAgentEnv c .:: receiveFile c -- | Send XFTP file xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 7d7d1180b..77b1c4ccf 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -337,7 +337,7 @@ data ACommand (p :: AParty) (e :: AEntity) where SUSPENDED :: ACommand Agent AENone -- XFTP commands and responses RFPROG :: Int -> Int -> ACommand Agent AERcvFile - RFDONE :: FilePath -> ACommand Agent AERcvFile + RFDONE :: ACommand Agent AERcvFile RFERR :: AgentErrorType -> ACommand Agent AERcvFile SFPROG :: Int -> Int -> ACommand Agent AESndFile SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile @@ -443,7 +443,7 @@ aCommandTag = \case ERR _ -> ERR_ SUSPENDED -> SUSPENDED_ RFPROG {} -> RFPROG_ - RFDONE {} -> RFDONE_ + RFDONE -> RFDONE_ RFERR {} -> RFERR_ SFPROG {} -> SFPROG_ SFDONE {} -> SFDONE_ @@ -1447,7 +1447,7 @@ commandP binaryP = ERR_ -> s (ERR <$> strP) SUSPENDED_ -> pure SUSPENDED RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal) - RFDONE_ -> s (RFDONE <$> strP) + RFDONE_ -> pure RFDONE RFERR_ -> s (RFERR <$> strP) SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal) SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP) @@ -1511,7 +1511,7 @@ serializeCommand = \case OK -> s OK_ SUSPENDED -> s SUSPENDED_ RFPROG rcvd total -> s (RFPROG_, rcvd, total) - RFDONE fPath -> s (RFDONE_, fPath) + RFDONE -> s RFDONE_ RFERR e -> s (RFERR_, e) SFPROG sent total -> s (SFPROG_, sent, total) SFDONE sd rds -> B.unwords [s SFDONE_, serializeBinary (sfDone sd rds)] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 9d5e5e14e..9252682c2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -132,7 +132,6 @@ module Simplex.Messaging.Agent.Store.SQLite updateRcvFileStatus, updateRcvFileError, updateRcvFileComplete, - updateRcvFileNoSavePath, updateRcvFileNoTmpPath, getNextRcvChunkToDownload, getNextRcvFileToDecrypt, @@ -1739,7 +1738,7 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> IO (Either StoreError RcvFileId) -createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = runExceptT $ do +createRcvFile db gVar userId fd@FileDescription {chunks} tmpPath savePath = runExceptT $ do (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd liftIO $ forM_ chunks $ \fc@FileChunk {replicas} -> do @@ -1753,8 +1752,8 @@ createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = runEx createWithRandomId gVar $ \rcvFileEntityId -> DB.execute db - "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, status) VALUES (?,?,?,?,?,?,?,?,?,?)" - (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, RFSReceiving) + "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_path, status) VALUES (?,?,?,?,?,?,?,?,?,?)" + (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, RFSReceiving) rcvFileId <- liftIO $ insertedRowId db pure (rcvFileEntityId, rcvFileId) insertChunk :: FileChunk -> DBRcvFileId -> IO Int64 @@ -1784,15 +1783,15 @@ getRcvFile db rcvFileId = runExceptT $ do DB.query db [sql| - SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, save_path, status + SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_path, status FROM rcv_files WHERE rcv_file_id = ? |] (Only rcvFileId) where - toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile - toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status) = - RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status, chunks = []} + toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, RcvFileStatus) -> RcvFile + toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, status) = + RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, status, chunks = []} getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk] getChunks rcvFileEntityId userId fileTmpPath = do chunks <- @@ -1859,15 +1858,10 @@ updateRcvFileError db rcvFileId errStr = do updatedAt <- getCurrentTime DB.execute db "UPDATE rcv_files SET tmp_path = NULL, error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId) -updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> FilePath -> IO () -updateRcvFileComplete db rcvFileId savePath = do +updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileComplete db rcvFileId = do updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET tmp_path = NULL, save_path = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (savePath, RFSComplete, updatedAt, rcvFileId) - -updateRcvFileNoSavePath :: DB.Connection -> DBRcvFileId -> IO () -updateRcvFileNoSavePath db rcvFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET save_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, status = ?, updated_at = ? WHERE rcv_file_id = ?" (RFSComplete, updatedAt, rcvFileId) updateRcvFileNoTmpPath :: DB.Connection -> DBRcvFileId -> IO () updateRcvFileNoTmpPath db rcvFileId = do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs index 2ad06b4c8..8853deb0e 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs @@ -28,8 +28,7 @@ CREATE TABLE rcv_files ( nonce BLOB NOT NULL, chunk_size INTEGER NOT NULL, tmp_path TEXT, - save_dir TEXT NOT NULL, - save_path TEXT, + save_path TEXT NOT NULL, status TEXT NOT NULL, error TEXT, created_at TEXT NOT NULL DEFAULT (datetime('now')), diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index ee7850191..b09f5a97b 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -302,8 +302,7 @@ CREATE TABLE rcv_files( nonce BLOB NOT NULL, chunk_size INTEGER NOT NULL, tmp_path TEXT, - save_dir TEXT NOT NULL, - save_path TEXT, + save_path TEXT NOT NULL, status TEXT NOT NULL, error TEXT, created_at TEXT NOT NULL DEFAULT(datetime('now')), diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 43c67a332..54ceb48ad 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -2,6 +2,7 @@ module AgentTests.SchemaDump where +import Control.DeepSeq import Control.Monad (void) import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations @@ -23,7 +24,7 @@ testVerifySchemaDump = do void $ createSQLiteStore testDB "" Migrations.app False void $ readCreateProcess (shell $ "touch " <> schema) "" savedSchema <- readFile schema - savedSchema `seq` pure () + savedSchema `deepseq` pure () void $ readCreateProcess (shell $ "sqlite3 " <> testDB <> " '.schema --indent' > " <> schema) "" currentSchema <- readFile schema savedSchema `shouldBe` currentSchema diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 3d6406c14..8e2d149bc 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -18,6 +18,7 @@ import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import System.Directory (doesDirectoryExist, getFileSize) import System.FilePath (()) +import System.Process (readCreateProcess, shell) import System.Timeout (timeout) import Test.Hspec import XFTPCLI @@ -48,13 +49,18 @@ testXFTPAgentReceive = withXFTPServer $ do ] -- receive file using agent rcp <- getSMPAgentClient agentCfg initAgentServers + let savePath = recipientFiles "testfile" + run $ "touch " <> savePath runRight_ $ do fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv - fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles - ("", fId', RFDONE path) <- rfGet rcp + fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath + ("", fId', RFDONE) <- rfGet rcp liftIO $ do fId' `shouldBe` fId - B.readFile path `shouldReturn` file + B.readFile savePath `shouldReturn` file + +run :: String -> IO () +run cmd = void $ readCreateProcess (shell cmd) "" getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient) getFileDescription path = @@ -82,10 +88,12 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do ] -- receive file using agent - should not succeed due to server being down + let savePath = recipientFiles "testfile" + run $ "touch " <> savePath rcp <- getSMPAgentClient agentCfg initAgentServers fId <- runRight $ do fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv - fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles + fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure fId disconnectAgentClient rcp @@ -95,11 +103,11 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do rcp' <- getSMPAgentClient agentCfg initAgentServers withXFTPServerStoreLogOn $ \_ -> do -- receive file using agent - should succeed with server up - ("", fId', RFDONE path) <- rfGet rcp' + ("", fId', RFDONE) <- rfGet rcp' liftIO $ do fId' `shouldBe` fId file <- B.readFile filePath - B.readFile path `shouldReturn` file + B.readFile savePath `shouldReturn` file -- tmp path should be removed after receiving file doesDirectoryExist (recipientFiles "xftp.encrypted") `shouldReturn` False @@ -124,9 +132,11 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file using agent - should not succeed due to server being down rcp <- getSMPAgentClient agentCfg initAgentServers + let savePath = recipientFiles "testfile" + run $ "touch " <> savePath fId <- runRight $ do fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv - fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles + fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure fId disconnectAgentClient rcp @@ -166,9 +176,11 @@ testXFTPAgentSendExperimental = do -- receive file using agent rcp <- getSMPAgentClient agentCfg initAgentServers + let savePath = recipientFiles "testfile" + run $ "touch " <> savePath runRight_ $ do - rfId <- xftpReceiveFile rcp 1 rfd $ Just recipientFiles - ("", rfId', RFDONE path) <- rfGet rcp + rfId <- xftpReceiveFile rcp 1 rfd (Just recipientFiles) savePath + ("", rfId', RFDONE) <- rfGet rcp liftIO $ do rfId' `shouldBe` rfId - B.readFile path `shouldReturn` file + B.readFile savePath `shouldReturn` file