xftp: pass save path to agent (#685)

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.*

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.*

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) ""
 

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

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)

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

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)]

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

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')),

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')),

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

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