core: XFTP accept; provide save path to agent (#2005)

2023-03-14 21:51:35 +04:00
parent 9b7fbfd513
commit fda41817e9
5 changed files with 41 additions and 21 deletions
--- a/cabal.project
+++ b/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: ddc2da8fe44f95928213522ec43a40154fd3c050
+    tag: db120b6d2eee04836a132f0bfbca9491cacf3dc8

 source-repository-package
    type: git
--- a/scripts/nix/sha256map.nix
+++ b/scripts/nix/sha256map.nix
@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."ddc2da8fe44f95928213522ec43a40154fd3c050" = "1c6bdl6vhy1h459hwsxdiw27xkckcw53c5g1g8fy2bp8gn9q5k4s";
+  "https://github.com/simplex-chat/simplexmq.git"."db120b6d2eee04836a132f0bfbca9491cacf3dc8" = "0md0i4vl84mdmkgwjrmlkipqm9k1rqbld0ld1xxss3z1xdb7fdrj";
  "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";
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -1768,11 +1768,13 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, rcvFileDescription
      connIds <- joinAgentConnectionAsync user True connReq . directMessage $ XFileAcpt fName
      filePath <- getRcvFilePath fileId filePath_ fName
      withStore $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
+    -- XFTP
+    (Just rfd, _) -> do
+      filePath <- getRcvFilePath fileId filePath_ fName
+      ci <- withStore $ \db -> xftpAcceptRcvFT db user fileId filePath
+      receiveViaCompleteFD user fileId filePath rfd
+      pure ci
    -- group & direct file protocol
-    (Just _fd, _) -> do
-      -- check if file description is fully received, error otherwise
-      -- pass file description to the agent and save AgentRcvFileId
-      throwChatError $ CEFileInternal "XFTP file receiption not implemented"
    _ -> do
      chatRef <- withStore $ \db -> getChatRefByFileId db user fileId
      case (chatRef, grpMemberId) of
@@ -1813,6 +1815,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, rcvFileDescription
                 || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
             )

+receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> FilePath -> RcvFileDescr -> m ()
+receiveViaCompleteFD user fileId filePath RcvFileDescr {fileDescrText, fileDescrComplete} =
+  when fileDescrComplete $ do
+    rd <- parseRcvFileDescription fileDescrText
+    tmp <- readTVarIO =<< asks tempDirectory
+    aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd tmp filePath
+    withStore' $ \db -> updateRcvFileAgentId db fileId (AgentRcvFileId aFileId)
+
 getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> m FilePath
 getRcvFilePath fileId fPath_ fn = case fPath_ of
  Nothing ->
@@ -2225,7 +2235,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
          -- update chat item status
          -- send status to view
          pure ()
-        RFDONE _filePath -> do
+        RFDONE -> do
          ci <- withStore $ \db -> do
            liftIO $ do
              updateRcvFileStatus' db fileId FSComplete
@@ -2909,13 +2919,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do

    processFDMessage :: FileTransferId -> FileDescr -> m ()
    processFDMessage fileId fileDescr = do
-      rfd <- withStore $ \db -> appendRcvFD db userId fileId fileDescr
-      let RcvFileDescr {fileDescrText, fileDescrComplete} = rfd
-      when fileDescrComplete $ do
-        rd <- parseRcvFileDescription fileDescrText
-        tmp <- readTVarIO =<< asks tempDirectory
-        aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd tmp
-        withStore' $ \db -> updateRcvFileAgentId db fileId (AgentRcvFileId aFileId)
+      (rfd, RcvFileTransfer {fileStatus}) <- withStore $ \db -> do
+        rfd <- appendRcvFD db userId fileId fileDescr
+        ft <- getRcvFileTransfer db user fileId
+        pure (rfd, ft)
+      case fileStatus of
+        RFSAccepted RcvFileInfo {filePath} -> receiveViaCompleteFD user fileId filePath rfd
+        _ -> pure ()

    cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
    cancelMessageFile ct _sharedMsgId msgMeta = do
--- a/src/Simplex/Chat/Store.hs
+++ b/src/Simplex/Chat/Store.hs
@@ -183,6 +183,7 @@ module Simplex.Chat.Store
    getContactByFileId,
    acceptRcvInlineFT,
    startRcvInlineFT,
+    xftpAcceptRcvFT,
    updateRcvFileStatus,
    updateRcvFileStatus',
    createRcvFileChunk,
@@ -1439,7 +1440,9 @@ getLiveRcvFileTransfers db user@User {userId} = do
          SELECT f.file_id
          FROM files f
          JOIN rcv_files r USING (file_id)
-          WHERE f.user_id = ? AND r.file_status IN (?, ?) AND r.rcv_file_inline IS NULL
+          WHERE f.user_id = ? AND r.file_status IN (?, ?)
+            AND r.rcv_file_inline IS NULL
+            AND r.file_descr_id IS NULL
            AND r.created_at > ?
        |]
        (userId, FSAccepted, FSConnected, cutoffTs)
@@ -3050,12 +3053,14 @@ getRcvFileTransfer db User {userId} fileId = do
          WHERE f.user_id = ? AND f.file_id = ?
        |]
        (userId, fileId)
-  rcvFileTransfer rftRow
+  rfd <- liftIO $ getRcvFileDescrByFileId_ db fileId
+  rcvFileTransfer rfd rftRow
  where
    rcvFileTransfer ::
+      Maybe RcvFileDescr ->
      (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode) :. (Maybe Int64, Maybe AgentConnId) ->
      ExceptT StoreError IO RcvFileTransfer
-    rcvFileTransfer ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline) :. (connId_, agentConnId_)) = do
+    rcvFileTransfer rcvFileDescription ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline) :. (connId_, agentConnId_)) = do
      let fileInv = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
          fileInfo = (filePath_, connId_, agentConnId_)
      case contactName_ <|> memberName_ of
@@ -3069,7 +3074,7 @@ getRcvFileTransfer db User {userId} fileId = do
            FSCancelled -> ft name fileInv . RFSCancelled <$> rfi_ fileInfo
      where
        ft senderDisplayName fileInvitation fileStatus =
-          RcvFileTransfer {fileId, fileInvitation, fileStatus, rcvFileInline, rcvFileDescription = Nothing, senderDisplayName, chunkSize, cancelled, grpMemberId}
+          RcvFileTransfer {fileId, fileInvitation, fileStatus, rcvFileInline, rcvFileDescription, senderDisplayName, chunkSize, cancelled, grpMemberId}
        rfi fileInfo = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ fileInfo
        rfi_ = \case
          (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId}
@@ -3097,7 +3102,7 @@ getContactByFileId db user@User {userId} fileId = do
      ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
        DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId)

-acceptRcvInlineFT :: DB.Connection -> User -> Int64 -> FilePath -> ExceptT StoreError IO AChatItem
+acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
 acceptRcvInlineFT db user fileId filePath = do
  liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime
  getChatItemByFileId db user fileId
@@ -3106,7 +3111,12 @@ startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Mayb
 startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
  acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime

-acceptRcvFT_ :: DB.Connection -> User -> Int64 -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
+xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
+xftpAcceptRcvFT db user fileId filePath = do
+  liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime
+  getChatItemByFileId db user fileId
+
+acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
 acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
  DB.execute
    db
--- a/stack.yaml
+++ b/stack.yaml
@@ -49,7 +49,7 @@ extra-deps:
  # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
  # - ../simplexmq
  - github: simplex-chat/simplexmq
-    commit: ddc2da8fe44f95928213522ec43a40154fd3c050
+    commit: db120b6d2eee04836a132f0bfbca9491cacf3dc8
  - github: kazu-yamamoto/http2
    commit: 78e18f52295a7f89e828539a03fbcb24931461a3
  # - ../direct-sqlcipher