xftp: set app tmp directory (#2054)

cabal.project

@@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: 7e265e5c59dedaabd0b77ce55d49e0bc6fa92f20
+    tag: 0df7733125add475f9de88a362bcd526091f187c
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."7e265e5c59dedaabd0b77ce55d49e0bc6fa92f20" = "162j0187kzwihg0pa91mwqavk93jdx5y5davl7fik8q6svvwqrpq";
+  "https://github.com/simplex-chat/simplexmq.git"."0df7733125add475f9de88a362bcd526091f187c" = "09s2dimdq88lm4mb2xcl5vch2qb21llj8ss649vlxpkm69njpyj0";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
   "https://github.com/kazu-yamamoto/http2.git"."78e18f52295a7f89e828539a03fbcb24931461a3" = "05q165anvv0qrcxqbvq1dlvw0l8gmsa9kl6sazk1mfhz2g0yimdk";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";

src/Simplex/Chat.hs

@@ -78,7 +78,7 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (defaultSocksProxy)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure, exitSuccess)
-import System.FilePath (combine, splitExtensions, takeFileName)
+import System.FilePath (combine, splitExtensions, takeFileName, (</>))
 import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
 import Text.Read (readMaybe)
 import UnliftIO.Async
@@ -219,9 +219,15 @@ startChatController subConns enableExpireCIs = do
           then Just <$> async (subscribeUsers users)
           else pure Nothing
       atomically . writeTVar s $ Just (a1, a2)
+      startXFTP
       startCleanupManager
       when enableExpireCIs $ startExpireCIs users
       pure a1
+    startXFTP = do
+      tmp <- readTVarIO =<< asks tempDirectory
+      runExceptT (withAgent $ \a -> xftpStartWorkers a tmp) >>= \case
+        Left e -> liftIO $ print $ "Error starting XFTP workers: " <> show e
+        Right _ -> pure ()
     startCleanupManager = do
       cleanupAsync <- asks cleanupManagerAsync
       readTVarIO cleanupAsync >>= \case
@@ -355,6 +361,11 @@ processChatCommand = \case
     withAgent (`suspendAgent` t)
     ok_
   ResubscribeAllConnections -> withStore' getUsers >>= subscribeUsers >> ok_
+  -- has to be called before StartChat
+  SetTempFolder tf -> do
+    createDirectoryIfMissing True tf
+    asks tempDirectory >>= atomically . (`writeTVar` Just tf)
+    ok_
   SetFilesFolder ff -> do
     createDirectoryIfMissing True ff
     asks filesFolder >>= atomically . (`writeTVar` Just ff)
@@ -535,8 +546,8 @@ processChatCommand = \case
         let fileName = takeFileName file
             fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
             fInv = xftpFileInvitation fileName fileSize fileDescr
-        tmp <- readTVarIO =<< asks tempDirectory
-        aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) file n tmp
+        fsFilePath <- toFSFilePath file
+        aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) fsFilePath n
         -- TODO CRSndFileStart event for XFTP
         ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv $ AgentSndFileId aFileId
         let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
@@ -1758,7 +1769,7 @@ callStatusItemContent user Contact {contactId} chatItemId receivedStatus = do
 -- used during file transfer for actual operations with file system
 toFSFilePath :: ChatMonad m => FilePath -> m FilePath
 toFSFilePath f =
-  maybe f (<> "/" <> f) <$> (readTVarIO =<< asks filesFolder)
+  maybe f (</> f) <$> (readTVarIO =<< asks filesFolder)
 
 acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe Bool -> Maybe FilePath -> m AChatItem
 acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId} rcvInline_ filePath_ = do
@@ -1822,8 +1833,7 @@ receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr ->
 receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} =
   when fileDescrComplete $ do
     rd <- parseRcvFileDescription fileDescrText
-    tmp <- readTVarIO =<< asks tempDirectory
-    aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd tmp
+    aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd
     startReceivingFile user fileId
     withStore' $ \db -> updateRcvFileAgentId db fileId (AgentRcvFileId aFileId)
 
@@ -2260,7 +2270,8 @@ processAgentMsgRcvFile _corrId aFileId msg =
           case liveRcvFileTransferPath ft of
             Nothing -> throwChatError $ CEInternalError "no target path for received XFTP file"
             Just targetPath -> do
-              renameFile xftpPath targetPath
+              fsTargetPath <- toFSFilePath targetPath
+              renameFile xftpPath fsTargetPath
               ci <- withStore $ \db -> do
                 liftIO $ do
                   updateRcvFileStatus db fileId FSComplete
@@ -4202,6 +4213,7 @@ chatCommandP =
       "/_app activate" $> APIActivateChat,
       "/_app suspend " *> (APISuspendChat <$> A.decimal),
       "/_resubscribe all" $> ResubscribeAllConnections,
+      "/_temp_folder " *> (SetTempFolder <$> filePath),
       "/_files_folder " *> (SetFilesFolder <$> filePath),
       "/_db export " *> (APIExportArchive <$> jsonP),
       "/_db import " *> (APIImportArchive <$> jsonP),

src/Simplex/Chat/Controller.hs

@@ -196,6 +196,7 @@ data ChatCommand
   | APIActivateChat
   | APISuspendChat {suspendTimeout :: Int}
   | ResubscribeAllConnections
+  | SetTempFolder FilePath
   | SetFilesFolder FilePath
   | SetIncognito Bool
   | APIExportArchive ArchiveConfig

stack.yaml

@@ -49,7 +49,7 @@ extra-deps:
   # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
   # - ../simplexmq
   - github: simplex-chat/simplexmq
-    commit: 7e265e5c59dedaabd0b77ce55d49e0bc6fa92f20
+    commit: 0df7733125add475f9de88a362bcd526091f187c
   - github: kazu-yamamoto/http2
     commit: 78e18f52295a7f89e828539a03fbcb24931461a3
   # - ../direct-sqlcipher

tests/ChatClient.hs

@@ -320,7 +320,7 @@ xftpServerConfig =
   XFTPServerConfig
     { xftpPort = xftpTestPort,
       fileIdSize = 16,
-      storeLogFile = Nothing,
+      storeLogFile = Just "tests/tmp/xftp-server-store.log",
       filesPath = xftpServerFiles,
       fileSizeQuota = Nothing,
       allowedChunkSizes = [kb 128, kb 256, mb 1, mb 4],

tests/ChatTests/Files.hs

@@ -50,6 +50,8 @@ 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 "with relative paths: send and receive file" testXFTPWithRelativePaths
+    it "continue receiving file after restart" testXFTPContinueRcv
 
 runTestFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
 runTestFileTransfer alice bob = do
@@ -940,6 +942,78 @@ testXFTPFileTransfer =
   where
     cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
 
+testXFTPWithRelativePaths :: HasCallStack => FilePath -> IO ()
+testXFTPWithRelativePaths =
+  testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
+    withXFTPServer $ do
+      -- agent is passed xftp work directory only on chat start,
+      -- so for test we work around by stopping and starting chat
+      alice ##> "/_stop"
+      alice <## "chat stopped"
+      alice #$> ("/_files_folder ./tests/fixtures", id, "ok")
+      alice #$> ("/_temp_folder ./tests/tmp/alice_xftp", id, "ok")
+      alice ##> "/_start"
+      alice <## "chat started"
+
+      bob ##> "/_stop"
+      bob <## "chat stopped"
+      bob #$> ("/_files_folder ./tests/tmp/bob_files", id, "ok")
+      bob #$> ("/_temp_folder ./tests/tmp/bob_xftp", id, "ok")
+      bob ##> "/_start"
+      bob <## "chat started"
+
+      connectUsers alice bob
+
+      alice #> "/f @bob test.pdf"
+      alice <## "use /fc 1 to cancel sending"
+      bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)"
+      bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
+      bob ##> "/fr 1"
+      bob <## "saving file 1 from alice to test.pdf"
+      -- alice <## "started sending file 1 (test.pdf) to bob" -- TODO "started uploading" ?
+      alice <## "completed sending file 1 (test.pdf) to bob"
+      bob <## "started receiving file 1 (test.pdf) from alice"
+      bob <## "completed receiving file 1 (test.pdf) from alice"
+
+      src <- B.readFile "./tests/fixtures/test.pdf"
+      dest <- B.readFile "./tests/tmp/bob_files/test.pdf"
+      dest `shouldBe` src
+  where
+    cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}}
+
+testXFTPContinueRcv :: HasCallStack => FilePath -> IO ()
+testXFTPContinueRcv tmp = do
+  withXFTPServer $ do
+    withNewTestChatCfg tmp cfg "alice" aliceProfile $ \alice -> do
+      withNewTestChatCfg tmp cfg "bob" bobProfile $ \bob -> 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 [<dir>/ | <path>] to receive it"
+        -- alice <## "started sending file 1 (test.pdf) to bob" -- TODO "started uploading" ?
+        alice <## "completed sending file 1 (test.pdf) to bob"
+
+  -- server is down - file is not received
+  withTestChatCfg tmp cfg "bob" $ \bob -> do
+    bob <## "1 contacts connected (use /cs for the list)"
+    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 </)
+
+  withXFTPServer $ do
+    -- server is up - file reception is continued
+    withTestChatCfg tmp cfg "bob" $ \bob -> do
+      bob <## "1 contacts connected (use /cs for the list)"
+      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"}
+
 startFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
 startFileTransfer alice bob =
   startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"