xftp: recoverable send - spike (#707)

src/Simplex/FileTransfer/Agent.hs

@@ -19,7 +19,7 @@ module Simplex.FileTransfer.Agent
     deleteRcvFile,
     -- Sending files
     sendFileExperimental,
-    _sendFile,
+    sendFile,
   )
 where
 
@@ -33,18 +33,21 @@ import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Composition ((.:))
 import Data.Int (Int64)
 import Data.List (foldl', isSuffixOf, partition)
 import Data.List.NonEmpty (nonEmpty)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
+import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
-import Simplex.FileTransfer.Client.Main (CLIError, SendOptions (..), cliSendFileOpts)
+import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
+import Simplex.FileTransfer.Client.Main
 import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileParty (..), FilePartyI, SFileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import Simplex.FileTransfer.Types
 import Simplex.FileTransfer.Util (removePath, uniqueCombine)
@@ -53,8 +56,12 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.SQLite
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (EntityId, XFTPServer, XFTPServerWithAuth)
+import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (liftError, liftIOEither, tshow, whenM)
 import System.FilePath (takeFileName, (</>))
@@ -72,24 +79,25 @@ startWorkers c workDir = do
     startFiles = do
       rcvFilesTTL <- asks (rcvFilesTTL . config)
       pendingRcvServers <- withStore' c (`getPendingRcvFilesServers` rcvFilesTTL)
-      forM_ pendingRcvServers $ \s -> addXFTPWorker c (Just s)
+      forM_ pendingRcvServers $ \s -> addXFTPRcvWorker c (Just s)
       -- start local worker for files pending decryption,
       -- no need to make an extra query for the check
       -- as the worker will check the store anyway
-      addXFTPWorker c Nothing
+      addXFTPRcvWorker c Nothing
 
 closeXFTPAgent :: MonadUnliftIO m => XFTPAgent -> m ()
-closeXFTPAgent XFTPAgent {xftpWorkers} = do
-  ws <- atomically $ stateTVar xftpWorkers (,M.empty)
-  mapM_ (uninterruptibleCancel . snd) ws
+closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
+  stopWorkers xftpRcvWorkers
+  stopWorkers xftpSndWorkers
+  where
+    stopWorkers wsSel = do
+      ws <- atomically $ stateTVar wsSel (,M.empty)
+      mapM_ (uninterruptibleCancel . snd) ws
 
 receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
 receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) = do
   g <- asks idsDrg
-  workPath <- getXFTPWorkPath
-  ts <- liftIO getCurrentTime
-  let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts
-  prefixPath <- uniqueCombine workPath (isoTime <> "_rcv.xftp")
+  prefixPath <- getPrefixPath "rcv.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
       relTmpPath = relPrefixPath </> "xftp.encrypted"
@@ -102,9 +110,16 @@ receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) = do
   where
     downloadChunk :: AgentMonad m => FileChunk -> m ()
     downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
-      addXFTPWorker c (Just server)
+      addXFTPRcvWorker c (Just server)
     downloadChunk _ = throwError $ INTERNAL "no replicas"
 
+getPrefixPath :: AgentMonad m => String -> m FilePath
+getPrefixPath suffix = do
+  workPath <- getXFTPWorkPath
+  ts <- liftIO getCurrentTime
+  let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts
+  uniqueCombine workPath (isoTime <> "_" <> suffix)
+
 toFSFilePath :: AgentMonad m => FilePath -> m FilePath
 toFSFilePath f = (</> f) <$> getXFTPWorkPath
 
@@ -113,22 +128,32 @@ createEmptyFile fPath = do
   h <- openFile fPath AppendMode
   liftIO $ B.hPut h "" >> hFlush h
 
-addXFTPWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
-addXFTPWorker c srv_ = do
-  ws <- asks $ xftpWorkers . xftpAgent
+addXFTPRcvWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPRcvWorker c = addWorker c xftpRcvWorkers runXFTPRcvWorker runXFTPRcvLocalWorker
+
+addWorker ::
+  AgentMonad m =>
+  AgentClient ->
+  (XFTPAgent -> TMap (Maybe XFTPServer) (TMVar (), Async ())) ->
+  (AgentClient -> XFTPServer -> TMVar () -> m ()) ->
+  (AgentClient -> TMVar () -> m ()) ->
+  Maybe XFTPServer ->
+  m ()
+addWorker c wsSel runWorker runWorkerNoSrv srv_ = do
+  ws <- asks $ wsSel . xftpAgent
   atomically (TM.lookup srv_ ws) >>= \case
     Nothing -> do
       doWork <- newTMVarIO ()
-      let runWorker = case srv_ of
-            Just srv -> runXFTPWorker c srv doWork
-            Nothing -> runXFTPLocalWorker c doWork
-      worker <- async $ runWorker `E.finally` atomically (TM.delete srv_ ws)
+      let runWorker' = case srv_ of
+            Just srv -> runWorker c srv doWork
+            Nothing -> runWorkerNoSrv c doWork
+      worker <- async $ runWorker' `E.finally` atomically (TM.delete srv_ ws)
       atomically $ TM.insert srv_ (doWork, worker) ws
     Just (doWork, _) ->
       void . atomically $ tryPutTMVar doWork ()
 
-runXFTPWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
-runXFTPWorker c srv doWork = do
+runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPRcvWorker c srv doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     agentOperationBracket c AORcvNetwork waitUntilActive runXftpOperation
@@ -140,30 +165,20 @@ runXFTPWorker c srv doWork = do
       nextChunk <- withStore' c $ \db -> getNextRcvChunkToDownload db srv rcvFilesTTL
       case nextChunk of
         Nothing -> noWorkToDo
-        Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
-        Just fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, delay} : _} -> do
+        Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
+        Just fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, delay} : _} -> do
           ri <- asks $ reconnectInterval . config
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryInterval ri' $ \delay' loop ->
             downloadFileChunk fc replica
-              `catchError` retryOnError delay' loop (workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) . show)
+              `catchError` \e -> retryOnError c AORcvNetwork "XFTP rcv worker" loop (retryMaintenance e delay') (retryDone e) e
           where
-            retryOnError :: Int64 -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
-            retryOnError replicaDelay loop done e = do
-              logError $ "XFTP worker error: " <> tshow e
-              if temporaryAgentError e
-                then retryLoop
-                else done e
-              where
-                retryLoop = do
-                  notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
-                  when notifyOnRetry $ notifyInternalError c rcvFileEntityId $ show e
-                  closeXFTPServerClient c userId replica
-                  withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
-                  atomically $ endAgentOperation c AORcvNetwork
-                  atomically $ throwWhenInactive c
-                  atomically $ beginAgentOperation c AORcvNetwork
-                  loop
+            retryMaintenance e replicaDelay = do
+              notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
+              when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e
+              closeXFTPServerClient c userId server replicaId
+              withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
+            retryDone e = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (show e)
     downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> m ()
     downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do
       fsFileTmpPath <- toFSFilePath fileTmpPath
@@ -178,8 +193,8 @@ runXFTPWorker c srv doWork = do
             complete = all chunkReceived chunks
         liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
         pure (complete, RFPROG rcvd total)
-      liftIO $ notify c rcvFileEntityId progress
-      when complete $ addXFTPWorker c Nothing
+      notify c rcvFileEntityId progress
+      when complete $ addXFTPRcvWorker c Nothing
       where
         receivedSize :: [RcvFileChunk] -> Int64
         receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0
@@ -188,17 +203,28 @@ runXFTPWorker c srv doWork = do
           | otherwise = 0
         chunkReceived RcvFileChunk {replicas} = any received replicas
 
-workerInternalError :: AgentMonad m => AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> m ()
-workerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
+retryOnError :: AgentMonad m => AgentClient -> AgentOperation -> Text -> m () -> m () -> m () -> AgentErrorType -> m ()
+retryOnError c agentOp name loop maintenance done e = do
+  logError $ name <> " error: " <> tshow e
+  if temporaryAgentError e
+    then retryLoop
+    else done
+  where
+    retryLoop = do
+      maintenance `catchError` \_ -> pure ()
+      atomically $ endAgentOperation c agentOp
+      atomically $ throwWhenInactive c
+      atomically $ beginAgentOperation c agentOp
+      loop
+
+rcvWorkerInternalError :: AgentMonad m => AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> m ()
+rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
   forM_ tmpPath (removePath <=< toFSFilePath)
   withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
-  notifyInternalError c rcvFileEntityId internalErrStr
+  notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr
 
-notifyInternalError :: (MonadUnliftIO m) => AgentClient -> RcvFileId -> String -> m ()
-notifyInternalError AgentClient {subQ} rcvFileEntityId internalErrStr = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC SAERcvFile $ RFERR $ INTERNAL internalErrStr)
-
-runXFTPLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
-runXFTPLocalWorker c doWork = do
+runXFTPRcvLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+runXFTPRcvLocalWorker c doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     -- TODO agentOperationBracket?
@@ -211,7 +237,7 @@ runXFTPLocalWorker c doWork = do
       case nextFile of
         Nothing -> noWorkToDo
         Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
-          decryptFile f `catchError` (workerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
+          decryptFile f `catchError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, status, chunks} = do
@@ -222,9 +248,9 @@ runXFTPLocalWorker c doWork = do
       chunkPaths <- getChunkPaths chunks
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
       void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure fsSavePath
+      notify c rcvFileEntityId $ RFDONE fsSavePath
       forM_ tmpPath (removePath <=< toFSFilePath)
       withStore' c (`updateRcvFileComplete` rcvFileId)
-      liftIO $ notify c rcvFileEntityId $ RFDONE fsSavePath
       where
         getChunkPaths :: [RcvFileChunk] -> m [FilePath]
         getChunkPaths [] = pure []
@@ -264,7 +290,7 @@ sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients =
       createDirectoryIfMissing False tempPath
       runSend fileName outputDir tempPath `catchError` \e -> do
         cleanup outputDir tempPath
-        liftIO $ notify c sndFileId $ SFERR e
+        notify c sndFileId $ SFERR e
       where
         runSend :: String -> FilePath -> FilePath -> m ()
         runSend fileName outputDir tempPath = do
@@ -281,7 +307,7 @@ sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients =
           liftCLI $ cliSendFileOpts sendOptions False $ notify c sndFileId .: SFPROG
           (sndDescr, rcvDescrs) <- readDescrs outputDir fileName
           cleanup outputDir tempPath
-          liftIO $ notify c sndFileId $ SFDONE sndDescr rcvDescrs
+          notify c sndFileId $ SFDONE sndDescr rcvDescrs
         cleanup :: FilePath -> FilePath -> m ()
         cleanup outputDir tempPath = do
           removePath tempPath
@@ -299,71 +325,173 @@ sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients =
     readDescr :: FilePartyI p => FilePath -> m (ValidFileDescription p)
     readDescr f = liftIOEither $ first INTERNAL . strDecode <$> B.readFile f
 
-notify :: forall e. AEntityI e => AgentClient -> EntityId -> ACommand 'Agent e -> IO ()
+notify :: forall m e. (MonadUnliftIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
 
--- _sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
-_sendFile :: AgentClient -> UserId -> FilePath -> Int -> m SndFileId
-_sendFile _c _userId _filePath _numRecipients = do
-  -- db: create file in status New without chunks
-  -- add local snd worker for encryption
-  -- return file id to client
-  undefined
+sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
+sendFile c userId filePath numRecipients = do
+  g <- asks idsDrg
+  prefixPath <- getPrefixPath "snd.xftp"
+  createDirectory prefixPath
+  let relPrefixPath = takeFileName prefixPath
+  key <- liftIO C.randomSbKey
+  nonce <- liftIO C.randomCbNonce
+  -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
+  fId <- withStore c $ \db -> createSndFile db g userId numRecipients filePath relPrefixPath key nonce
+  addXFTPSndWorker c Nothing
+  pure fId
 
-_runXFTPSndLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
-_runXFTPSndLocalWorker _c doWork = do
+addXFTPSndWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPSndWorker c = addWorker c xftpSndWorkers runXFTPSndWorker runXFTPSndPrepareWorker
+
+runXFTPSndPrepareWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+runXFTPSndPrepareWorker c doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
+    -- TODO agentOperationBracket
     runXftpOperation
   where
     runXftpOperation :: m ()
     runXftpOperation = do
-      -- db: get next snd file to encrypt (in status New)
-      -- ? (or Encrypted to retry create? - see below)
-      -- with fixed retries (?) encryptFile
-      undefined
-    _encryptFile :: SndFile -> m ()
-    _encryptFile _sndFile = do
-      -- if enc path exists, remove it
-      -- if enc path doesn't exist:
-      --   - choose enc path
-      --   - touch file, db: update enc path (?)
-      -- calculate chunk sizes, encrypt file to enc path
-      -- calculate digest
-      -- prepare chunk specs
-      -- db:
-      --   - update file status to Encrypted
-      --   - create chunks according to chunk specs
-      -- ? since which servers are online is unknown,
-      -- ? we can't blindly assign servers to replicas.
-      -- ? should we XFTP create chunks on servers here,
-      -- ? with retrying for different servers,
-      -- ? keeping a list of servers that were tried?
-      -- ? then we can add replicas to chunks in db
-      -- ? and update file status to Uploading,
-      -- ? probably in same transaction as creating chunks,
-      -- ? and add XFTP snd workers for uploading chunks.
-      undefined
+      nextFile <- withStore' c getNextSndFileToPrepare
+      case nextFile of
+        Nothing -> noWorkToDo
+        Just f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
+          prepareFile f `catchError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    prepareFile :: SndFile -> m ()
+    prepareFile SndFile {prefixPath = Nothing} =
+      throwError $ INTERNAL "no prefix path"
+    prepareFile sndFile@SndFile {sndFileId, prefixPath = Just ppath, status} = do
+      SndFile {numRecipients, chunks} <-
+        if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
+          then do
+            let encPath = sndFileEncPath ppath
+            fsEncPath <- toFSFilePath encPath
+            when (status == SFSEncrypting) $
+              whenM (doesFileExist fsEncPath) $ removeFile fsEncPath
+            withStore' c $ \db -> updateSndFileStatus db sndFileId SFSEncrypting
+            (digest, chunkSpecs) <- encryptFileForUpload sndFile encPath
+            withStore c $ \db -> do
+              updateSndFileEncrypted db sndFileId digest chunkSpecs
+              getSndFile db sndFileId
+          else pure sndFile
+      maxRecipients <- asks (xftpMaxRecipientsPerRequest . config)
+      let numRecipients' = min numRecipients maxRecipients
+      -- concurrently?
+      forM_ chunks $ createChunk numRecipients'
+      withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
+      where
+        encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [XFTPChunkSpec])
+        encryptFileForUpload SndFile {key, nonce, filePath} encPath = do
+          let fileName = takeFileName filePath
+          fileSize <- fromInteger <$> getFileSize filePath
+          when (fileSize > maxFileSize) $ throwError $ INTERNAL "max file size exceeded"
+          let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
+              fileSize' = fromIntegral (B.length fileHdr) + fileSize
+              chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
+              chunkSizes' = map fromIntegral chunkSizes
+              encSize = sum chunkSizes'
+          void $ liftError (INTERNAL . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize encPath
+          digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
+          let chunkSpecs = prepareChunkSpecs encPath chunkSizes
+          pure (FileDigest digest, chunkSpecs)
+        createChunk :: Int -> SndFileChunk -> m ()
+        createChunk numRecipients' SndFileChunk {sndChunkId, userId, chunkSpec} = do
+          (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+          rKeys <- liftIO $ L.fromList <$> replicateM numRecipients' (C.generateSignatureKeyPair C.SEd25519)
+          ch@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
+          -- TODO with retry on temporary errors
+          srvAuth@(ProtoServerWithAuth srv _) <- getServer
+          (sndId, rIds) <- agentXFTPCreateChunk c userId srvAuth spKey ch (L.map fst rKeys)
+          let rcvIdsKeys = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
+          withStore' c $ \db -> createSndFileReplica db sndChunkId (FileDigest digest) srv (ChunkReplicaId sndId) spKey rcvIdsKeys
+          addXFTPSndWorker c $ Just srv
+        getServer :: m XFTPServerWithAuth
+        getServer = do
+          -- TODO get user servers from config
+          -- TODO choose next server (per chunk? per file?)
+          undefined
 
-_runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
-_runXFTPSndWorker c _srv doWork = do
+sndWorkerInternalError :: AgentMonad m => AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> String -> m ()
+sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = do
+  forM_ prefixPath (removePath <=< toFSFilePath)
+  withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr
+  notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr
+
+runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
+runXFTPSndWorker c srv doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     agentOperationBracket c AOSndNetwork throwWhenInactive runXftpOperation
   where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
     runXftpOperation :: m ()
     runXftpOperation = do
-      -- db: get next snd chunk to upload (replica is not uploaded)
-      -- with retry interval uploadChunk
-      --   - with fixed retries, repeat N times:
-      --     check if other files are in upload, delay (see xftpSndFiles in XFTPAgent)
-      undefined
-    _uploadFileChunk :: SndFileChunk -> m ()
-    _uploadFileChunk _sndFileChunk = do
-      -- add file id to xftpSndFiles
-      -- XFTP upload chunk
-      -- db: update replica status to Uploaded, return SndFile
-      -- if all SndFile's replicas are uploaded:
-      --   - serialize file descriptions and notify client
-      --   - remove file id from xftpSndFiles
-      undefined
+      nextChunk <- withStore' c $ \db -> getNextSndChunkToUpload db srv
+      case nextChunk of
+        Nothing -> noWorkToDo
+        Just SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
+        Just fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, replicaId, delay} : _} -> do
+          ri <- asks $ reconnectInterval . config
+          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
+          withRetryInterval ri' $ \delay' loop ->
+            uploadFileChunk fc replica
+              `catchError` \e -> retryOnError c AOSndNetwork "XFTP snd worker" loop (retryMaintenance e delay') (retryDone e) e
+          where
+            retryMaintenance e replicaDelay = do
+              notifyOnRetry <- asks (xftpNotifyErrsOnRetry . config)
+              when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
+              closeXFTPServerClient c userId server replicaId
+              withStore' c $ \db -> updateRcvChunkReplicaDelay db sndChunkReplicaId replicaDelay
+            retryDone e = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (show e)
+    uploadFileChunk :: SndFileChunk -> SndFileChunkReplica -> m ()
+    uploadFileChunk sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec} replica = do
+      replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica
+      agentXFTPUploadChunk c userId replica' chunkSpec
+      sf@SndFile {sndFileEntityId, prefixPath, chunks} <- withStore c $ \db -> do
+        updateSndChunkReplicaStatus db sndChunkReplicaId SFRSUploaded
+        getSndFile db sndFileId
+      let complete = all chunkUploaded chunks
+      -- TODO calculate progress, notify SFPROG
+      when complete $ do
+        sndDescr <- sndFileToSndDescr sf
+        rcvDescrs <- sndFileToRcvDescrs sf
+        notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
+        forM_ prefixPath (removePath <=< toFSFilePath)
+        withStore' c $ \db -> updateSndFileStatus db sndFileId SFSComplete
+      where
+        addRecipients :: SndFileChunk -> SndFileChunkReplica -> m SndFileChunkReplica
+        addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys}
+          | length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients"
+          | length rcvIdsKeys == numRecipients = pure cr
+          | otherwise = do
+            maxRecipients <- asks (xftpMaxRecipientsPerRequest . config)
+            let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
+            rKeys <- liftIO $ L.fromList <$> replicateM numRecipients' (C.generateSignatureKeyPair C.SEd25519)
+            rIds <- agentXFTPAddRecipients c userId cr (L.map fst rKeys)
+            let rcvIdsKeys' = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
+            cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr rcvIdsKeys'
+            addRecipients ch cr'
+        sndFileToSndDescr :: SndFile -> m (ValidFileDescription 'FSender)
+        sndFileToSndDescr SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
+        sndFileToSndDescr SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
+        sndFileToSndDescr SndFile {digest = Just digest, key, nonce, chunks = chunks@(fstChunk : _)} = do
+          let chunkSize = FileSize $ sndChunkSize fstChunk
+              size = FileSize $ sum $ map (fromIntegral . sndChunkSize) chunks
+          descrChunks <- mapM toDescrChunk chunks
+          let fd = FileDescription {party = SFSender, size, digest, key, nonce, chunkSize, chunks = descrChunks}
+          either (throwError . INTERNAL) pure $ validateFileDescription' fd
+          where
+            toDescrChunk :: SndFileChunk -> m FileChunk
+            toDescrChunk SndFileChunk {digest = Nothing} = throwError $ INTERNAL "snd file chunk has no digest"
+            toDescrChunk SndFileChunk {replicas = []} = throwError $ INTERNAL "snd file chunk has no replicas"
+            toDescrChunk ch@SndFileChunk {chunkNo, digest = Just chDigest, replicas = (SndFileChunkReplica {server, replicaId, replicaKey} : _)} = do
+              let chunkSize = FileSize $ sndChunkSize ch
+                  replicas = [FileChunkReplica {server, replicaId, replicaKey}]
+              pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas}
+        sndFileToRcvDescrs :: SndFile -> m [ValidFileDescription 'FRecipient]
+        sndFileToRcvDescrs SndFile {} = do
+          undefined
+        chunkUploaded SndFileChunk {replicas} =
+          any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSUploaded) replicas

src/Simplex/FileTransfer/Client/Main.hs

@@ -16,6 +16,13 @@ module Simplex.FileTransfer.Client.Main
     cliSendFile,
     cliSendFileOpts,
     prepareChunkSizes,
+    prepareChunkSpecs,
+    chunkSize1,
+    chunkSize2,
+    chunkSize3,
+    maxFileSize,
+    fileSizeLen,
+    getChunkInfo,
   )
 where
 
@@ -332,12 +339,6 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
           let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
               replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
           pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas})
-        getChunkInfo :: SndPublicVerifyKey -> XFTPChunkSpec -> IO FileInfo
-        getChunkInfo sndKey XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
-          withFile chunkPath ReadMode $ \h -> do
-            hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-            digest <- LC.sha256Hash <$> LB.hGet h (fromIntegral chunkSize)
-            pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
         getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
         getXFTPServer gen = \case
           srv :| [] -> pure srv
@@ -406,6 +407,13 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       B.writeFile fdSndPath $ strEncode fdSnd
       pure (fdRcvPaths, fdSndPath)
 
+getChunkInfo :: SndPublicVerifyKey -> XFTPChunkSpec -> IO FileInfo
+getChunkInfo sndKey XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
+  withFile chunkPath ReadMode $ \h -> do
+    hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+    digest <- LC.sha256Hash <$> LB.hGet h (fromIntegral chunkSize)
+    pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
+
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
   getFileDescription' fileDescription >>= receiveFile

src/Simplex/FileTransfer/Description.hs

@@ -25,6 +25,7 @@ module Simplex.FileTransfer.Description
     YAMLFileDescription (..), -- for tests
     YAMLServerReplicas (..), -- for tests
     validateFileDescription,
+    validateFileDescription',
     groupReplicasByServer,
     replicaServer,
     fdSeparator,
@@ -205,6 +206,17 @@ validateFileDescription = \case
       chunkNos = map (chunkNo :: FileChunk -> Int) chunks
       chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
 
+-- TODO refactor
+validateFileDescription' :: FileDescription p -> Either String (ValidFileDescription p)
+validateFileDescription' = \case
+  fd@FileDescription {size, chunks}
+    | chunkNos /= [1 .. length chunks] -> Left "chunk numbers are not sequential"
+    | chunksSize chunks /= unFileSize size -> Left "chunks total size is different than file size"
+    | otherwise -> Right $ ValidFD fd
+    where
+      chunkNos = map (chunkNo :: FileChunk -> Int) chunks
+      chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
+
 encodeFileDescription :: FileDescription p -> YAMLFileDescription
 encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks} =
   YAMLFileDescription

src/Simplex/FileTransfer/Types.hs

@@ -11,12 +11,13 @@ import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.Messaging.Agent.Protocol (RcvFileId)
+import Simplex.Messaging.Agent.Protocol (RcvFileId, SndFileId)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (fromTextField_)
 import Simplex.Messaging.Protocol
+import System.FilePath ((</>))
 
 authTagSize :: Int64
 authTagSize = fromIntegral C.authTagSize
@@ -111,26 +112,31 @@ data RcvFileChunkReplica = RcvFileChunkReplica
 type DBSndFileId = Int64
 
 data SndFile = SndFile
-  { userId :: Int64,
-    sndFileId :: DBSndFileId,
-    size :: FileSize Int64,
-    digest :: FileDigest,
+  { sndFileId :: DBSndFileId,
+    sndFileEntityId :: SndFileId,
+    userId :: Int64,
+    numRecipients :: Int,
+    digest :: Maybe FileDigest,
     key :: C.SbKey,
     nonce :: C.CbNonce,
-    chunkSize :: FileSize Word32,
-    chunks :: [RcvFileChunk],
-    path :: FilePath,
-    encPath :: Maybe FilePath,
-    status :: SndFileStatus
+    chunks :: [SndFileChunk],
+    filePath :: FilePath,
+    prefixPath :: Maybe FilePath,
+    status :: SndFileStatus,
+    deleted :: Bool
   }
   deriving (Eq, Show)
 
+sndFileEncPath :: FilePath -> FilePath
+sndFileEncPath prefixPath = prefixPath </> "xftp.encrypted"
+
 data SndFileStatus
-  = SFSNew
-  | SFSEncrypting
-  | SFSEncrypted
-  | SFSUploading
-  | SFSComplete
+  = SFSNew -- db record created
+  | SFSEncrypting -- encryption started
+  | SFSEncrypted -- encryption complete
+  | SFSUploading -- all chunk replicas are created on servers
+  | SFSComplete -- all chunk replicas are uploaded
+  | SFSError -- permanent error
   deriving (Eq, Show)
 
 instance FromField SndFileStatus where fromField = fromTextField_ textDecode
@@ -144,6 +150,7 @@ instance TextEncoding SndFileStatus where
     "encrypted" -> Just SFSEncrypted
     "uploading" -> Just SFSUploading
     "complete" -> Just SFSComplete
+    "error" -> Just SFSError
     _ -> Nothing
   textEncode = \case
     SFSNew -> "new"
@@ -151,34 +158,51 @@ instance TextEncoding SndFileStatus where
     SFSEncrypted -> "encrypted"
     SFSUploading -> "uploading"
     SFSComplete -> "complete"
+    SFSError -> "error"
 
 data SndFileChunk = SndFileChunk
-  { userId :: Int64,
-    sndFileId :: DBSndFileId,
+  { sndFileId :: DBSndFileId,
+    sndFileEntityId :: SndFileId,
+    userId :: Int64,
+    numRecipients :: Int,
     sndChunkId :: Int64,
     chunkNo :: Int,
     chunkSpec :: XFTPChunkSpec,
-    digest :: FileDigest,
-    replicas :: [SndFileChunkReplica],
-    delay :: Maybe Int
+    filePrefixPath :: FilePath,
+    digest :: Maybe FileDigest,
+    replicas :: [SndFileChunkReplica]
   }
   deriving (Eq, Show)
 
+sndChunkSize :: SndFileChunk -> Word32
+sndChunkSize SndFileChunk {chunkSpec = XFTPChunkSpec {chunkSize}} = chunkSize
+
 data SndFileChunkReplica = SndFileChunkReplica
   { sndChunkReplicaId :: Int64,
     server :: XFTPServer,
     replicaId :: ChunkReplicaId,
     replicaKey :: C.APrivateSignKey,
     rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)],
-    -- created :: Bool,
-    uploaded :: Bool,
+    replicaStatus :: SndFileReplicaStatus,
+    delay :: Maybe Int64,
     retries :: Int
   }
   deriving (Eq, Show)
 
--- to be used in reply to client
-data SndFileDescription = SndFileDescription
-  { description :: String,
-    sender :: Bool
-  }
+data SndFileReplicaStatus
+  = SFRSCreated
+  | SFRSUploaded
   deriving (Eq, Show)
+
+instance FromField SndFileReplicaStatus where fromField = fromTextField_ textDecode
+
+instance ToField SndFileReplicaStatus where toField = toField . textEncode
+
+instance TextEncoding SndFileReplicaStatus where
+  textDecode = \case
+    "created" -> Just SFRSCreated
+    "uploaded" -> Just SFRSUploaded
+    _ -> Nothing
+  textEncode = \case
+    SFRSCreated -> "created"
+    SFRSUploaded -> "uploaded"