Merge pull request #584 from simplex-chat/xftp

XFTP

.github/workflows/build.yml

@@ -53,6 +53,8 @@ jobs:
         run: |
           mv $(cabal list-bin smp-server) smp-server-ubuntu-20_04-x86-64
           mv $(cabal list-bin ntf-server) ntf-server-ubuntu-20_04-x86-64
+          mv $(cabal list-bin xftp-server) xftp-server-ubuntu-20_04-x86-64
+          mv $(cabal list-bin xftp) xftp-ubuntu-20_04-x86-64
 
       - name: Build changelog
         if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
@@ -80,6 +82,8 @@ jobs:
             LICENSE
             smp-server-ubuntu-20_04-x86-64
             ntf-server-ubuntu-20_04-x86-64
+            xftp-server-ubuntu-20_04-x86-64
+            xftp-ubuntu-20_04-x86-64
           fail_on_unmatched_files: true
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

apps/smp-agent/Main.hs

@@ -21,6 +21,7 @@ servers =
   InitialAgentServers
     { smp = M.fromList [(1, L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"])],
       ntf = [],
+      xftp = M.fromList [],
       netCfg = defaultNetworkConfig
     }
 

apps/xftp-server/Main.hs

@@ -0,0 +1,18 @@
+module Main where
+
+import Control.Logger.Simple
+import Simplex.FileTransfer.Server.Main
+
+cfgPath :: FilePath
+cfgPath = "/etc/opt/simplex-xftp"
+
+logPath :: FilePath
+logPath = "/var/opt/simplex-xftp"
+
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
+main :: IO ()
+main = do
+  setLogLevel LogDebug -- change to LogError in production
+  withGlobalLogging logCfg $ xftpServerCLI cfgPath logPath

apps/xftp/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Simplex.FileTransfer.Client.Main
+
+main :: IO ()
+main = xftpClientCLI

cabal.project

@@ -12,6 +12,11 @@ source-repository-package
     location: https://github.com/simplex-chat/hs-socks.git
     tag: a30cc7a79a08d8108316094f8f2f82a0c5e1ac51
 
+source-repository-package
+    type: git
+    location: https://github.com/kazu-yamamoto/http2.git
+    tag: 78e18f52295a7f89e828539a03fbcb24931461a3
+
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/direct-sqlcipher.git

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 4.4.1
+version: 5.0.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -42,7 +42,7 @@ dependencies:
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
-  - http2 == 3.0.*
+  - http2 == 4.1.*
   - generic-random >= 1.3 && < 1.5
   - ini == 0.4.1
   - iso8601-time == 0.1.*
@@ -59,6 +59,7 @@ dependencies:
   - sqlcipher-simple == 0.4.*
   - stm == 2.5.*
   - template-haskell == 2.16.*
+  - temporary == 1.3.*
   - text == 1.2.*
   - time == 1.9.*
   - time-compat == 1.9.*
@@ -71,6 +72,7 @@ dependencies:
   - x509 == 1.7.*
   - x509-store == 1.6.*
   - x509-validation == 1.6.*
+  - yaml == 0.11.*
 
 flags:
   swift:
@@ -103,6 +105,14 @@ executables:
     ghc-options:
       - -threaded
 
+  xftp-server:
+    source-dirs: apps/xftp-server
+    main: Main.hs
+    dependencies:
+      - simplexmq
+    ghc-options:
+      - -threaded
+
   smp-agent:
     source-dirs: apps/smp-agent
     main: Main.hs
@@ -111,12 +121,21 @@ executables:
     ghc-options:
       - -threaded
 
+  xftp:
+    source-dirs: apps/xftp
+    main: Main.hs
+    dependencies:
+      - simplexmq
+    ghc-options:
+      - -threaded
+
 tests:
   simplexmq-test:
     source-dirs: tests
     main: Test.hs
     dependencies:
       - simplexmq
+      - deepseq == 1.4.*
       - hspec == 2.7.*
       - hspec-core == 2.7.*
       - HUnit == 1.6.*

rfcs/2022-12-26-simplex-file-transfer.md

@@ -132,16 +132,15 @@ File description format (yml):
 ```
 name: file.ext
 size: 33200000
-chunk: 8Mb
+chunk: 8mb
 hash: abc=
 key: abc=
 iv: abc=
-part_hashes: [def=, def=, def=, def=]
 parts:
   - server: xftp://abc=@example1.com
     chunks: [1:abc=:def=:ghi=, 3:abc=:def=:ghi=]
   - server: xftp://abc=@example2.com
-    chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=]
+    chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=:2mb]
   - server: xftp://abc=@example3.com
     chunks: [1:abc=:def=, 4:abc=:def=]
   - server: xftp://abc=@example4.com

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        4.4.1
+version:        5.0.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -34,6 +34,24 @@ flag swift
 
 library
   exposed-modules:
+      Simplex.FileTransfer
+      Simplex.FileTransfer.Agent
+      Simplex.FileTransfer.Client
+      Simplex.FileTransfer.Client.Agent
+      Simplex.FileTransfer.Client.Main
+      Simplex.FileTransfer.Client.Presets
+      Simplex.FileTransfer.Crypto
+      Simplex.FileTransfer.Description
+      Simplex.FileTransfer.Protocol
+      Simplex.FileTransfer.Server
+      Simplex.FileTransfer.Server.Env
+      Simplex.FileTransfer.Server.Main
+      Simplex.FileTransfer.Server.Stats
+      Simplex.FileTransfer.Server.Store
+      Simplex.FileTransfer.Server.StoreLog
+      Simplex.FileTransfer.Transport
+      Simplex.FileTransfer.Types
+      Simplex.FileTransfer.Util
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
       Simplex.Messaging.Agent.Env.SQLite
@@ -59,6 +77,8 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
@@ -132,7 +152,7 @@ library
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -147,6 +167,7 @@ library
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -159,6 +180,7 @@ library
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -193,7 +215,7 @@ executable ntf-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -209,6 +231,7 @@ executable ntf-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -221,6 +244,7 @@ executable ntf-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -255,7 +279,7 @@ executable smp-agent
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -271,6 +295,7 @@ executable smp-agent
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -283,6 +308,7 @@ executable smp-agent
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -317,7 +343,7 @@ executable smp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -333,6 +359,7 @@ executable smp-server
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -345,6 +372,135 @@ executable smp-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
+  default-language: Haskell2010
+  if flag(swift)
+    cpp-options: -DswiftJSON
+
+executable xftp
+  main-is: Main.hs
+  other-modules:
+      Paths_simplexmq
+  hs-source-dirs:
+      apps/xftp
+  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
+  build-depends:
+      QuickCheck ==2.14.*
+    , aeson ==2.0.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , bytestring ==0.10.*
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , cryptonite >=0.27 && <0.30
+    , cryptostore ==0.2.*
+    , data-default ==0.7.*
+    , direct-sqlcipher ==2.3.*
+    , directory ==1.3.*
+    , filepath ==1.4.*
+    , generic-random >=1.3 && <1.5
+    , http-types ==0.12.*
+    , http2 ==4.1.*
+    , ini ==0.4.1
+    , iso8601-time ==0.1.*
+    , memory ==0.15.*
+    , mtl ==2.2.*
+    , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.4
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
+    , simplexmq
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , template-haskell ==2.16.*
+    , temporary ==1.3.*
+    , text ==1.2.*
+    , time ==1.9.*
+    , time-compat ==1.9.*
+    , time-manager ==0.0.*
+    , tls >=1.6.0 && <1.7
+    , transformers ==0.5.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
+    , websockets ==0.12.*
+    , x509 ==1.7.*
+    , x509-store ==1.6.*
+    , x509-validation ==1.6.*
+    , yaml ==0.11.*
+  default-language: Haskell2010
+  if flag(swift)
+    cpp-options: -DswiftJSON
+
+executable xftp-server
+  main-is: Main.hs
+  other-modules:
+      Paths_simplexmq
+  hs-source-dirs:
+      apps/xftp-server
+  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
+  build-depends:
+      QuickCheck ==2.14.*
+    , aeson ==2.0.*
+    , ansi-terminal >=0.10 && <0.12
+    , asn1-encoding ==0.9.*
+    , asn1-types ==0.3.*
+    , async ==2.2.*
+    , attoparsec ==0.14.*
+    , base >=4.14 && <5
+    , base64-bytestring >=1.0 && <1.3
+    , bytestring ==0.10.*
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , cryptonite >=0.27 && <0.30
+    , cryptostore ==0.2.*
+    , data-default ==0.7.*
+    , direct-sqlcipher ==2.3.*
+    , directory ==1.3.*
+    , filepath ==1.4.*
+    , generic-random >=1.3 && <1.5
+    , http-types ==0.12.*
+    , http2 ==4.1.*
+    , ini ==0.4.1
+    , iso8601-time ==0.1.*
+    , memory ==0.15.*
+    , mtl ==2.2.*
+    , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.4
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , simple-logger ==0.1.*
+    , simplexmq
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , template-haskell ==2.16.*
+    , temporary ==1.3.*
+    , text ==1.2.*
+    , time ==1.9.*
+    , time-compat ==1.9.*
+    , time-manager ==0.0.*
+    , tls >=1.6.0 && <1.7
+    , transformers ==0.5.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
+    , websockets ==0.12.*
+    , x509 ==1.7.*
+    , x509-store ==1.6.*
+    , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -366,11 +522,16 @@ test-suite simplexmq-test
       CoreTests.ProtocolErrorTests
       CoreTests.RetryIntervalTests
       CoreTests.VersionRangeTests
+      FileDescriptionTests
       NtfClient
       NtfServerTests
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPAgent
+      XFTPCLI
+      XFTPClient
+      XFTPServerTests
       Paths_simplexmq
   hs-source-dirs:
       tests
@@ -394,6 +555,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.*
@@ -401,7 +563,7 @@ test-suite simplexmq-test
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , main-tester ==0.2.*
@@ -419,6 +581,7 @@ test-suite simplexmq-test
     , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
+    , temporary ==1.3.*
     , text ==1.2.*
     , time ==1.9.*
     , time-compat ==1.9.*
@@ -432,6 +595,7 @@ test-suite simplexmq-test
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON

src/Simplex/FileTransfer.hs

@@ -0,0 +1,14 @@
+module Simplex.FileTransfer where
+
+-- TODO
+-- Protocol
+-- Store (in memory storage)
+-- StoreLog (append only log)
+-- FileDescription
+-- Server
+-- Client
+-- Server/Main (server CLI)
+-- Client/Main (client CLI)
+--
+-- Transport for HTTP2 ?
+-- streaming Crypto

src/Simplex/FileTransfer/Agent.hs

@@ -0,0 +1,317 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.FileTransfer.Agent
+  ( -- Receiving files
+    receiveFile,
+    addXFTPWorker,
+    deleteRcvFile,
+    -- Sending files
+    sendFileExperimental,
+    _sendFile,
+  )
+where
+
+import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple (logError)
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Crypto.Random (ChaChaDRG, randomBytesGenerate)
+import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Char8 as B
+import Data.List (isSuffixOf, partition)
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as L
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Simplex.FileTransfer.Client.Main (CLIError, SendOptions (..), cliSendFile)
+import Simplex.FileTransfer.Crypto
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Types
+import Simplex.FileTransfer.Util (removePath, uniqueCombine)
+import Simplex.Messaging.Agent.Client
+import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store.SQLite
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (XFTPServer, XFTPServerWithAuth)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (liftError, liftIOEither, tshow)
+import System.FilePath (takeFileName, (</>))
+import UnliftIO
+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
+  g <- asks idsDrg
+  workPath <- maybe getTemporaryDirectory pure xftpWorkPath
+  ts <- liftIO getCurrentTime
+  let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts
+  prefixPath <- uniqueCombine workPath (isoTime <> "_rcv.xftp")
+  createDirectory prefixPath
+  let tmpPath = prefixPath </> "xftp.encrypted"
+  createDirectory tmpPath
+  let savePath = prefixPath </> "xftp.decrypted"
+  createEmptyFile savePath
+  fId <- withStore c $ \db -> createRcvFile db g userId fd prefixPath tmpPath savePath
+  forM_ chunks downloadChunk
+  pure fId
+  where
+    downloadChunk :: AgentMonad m => FileChunk -> m ()
+    downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
+      addXFTPWorker c (Just server)
+    downloadChunk _ = throwError $ INTERNAL "no replicas"
+
+createEmptyFile :: AgentMonad m => FilePath -> m ()
+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
+  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)
+      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
+  forever $ do
+    void . atomically $ readTMVar doWork
+    agentOperationBracket c AORcvNetwork throwWhenInactive runXftpOperation
+  where
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    runXftpOperation :: m ()
+    runXftpOperation = do
+      nextChunk <- withStore' c (`getNextRcvChunkToDownload` srv)
+      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
+          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)
+          where
+            retryOnError :: Int -> 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
+                  closeXFTPServerClient c userId replica
+                  withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
+                  atomically $ endAgentOperation c AORcvNetwork
+                  atomically $ throwWhenInactive c
+                  atomically $ beginAgentOperation c AORcvNetwork
+                  loop
+    downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> m ()
+    downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do
+      chunkPath <- uniqueCombine fileTmpPath $ show chunkNo
+      let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
+      agentXFTPDownloadChunk c userId replica chunkSpec
+      fileReceived <- withStore c $ \db -> runExceptT $ do
+        -- both actions can be done in a single store method
+        f <- ExceptT $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId rcvFileId chunkPath
+        let fileReceived = allChunksReceived f
+        when fileReceived $
+          liftIO $ updateRcvFileStatus db rcvFileId RFSReceived
+        pure fileReceived
+      when fileReceived $ addXFTPWorker c Nothing
+      where
+        allChunksReceived :: RcvFile -> Bool
+        allChunksReceived RcvFile {chunks} =
+          all (\RcvFileChunk {replicas} -> any received replicas) chunks
+
+workerInternalError :: AgentMonad m => AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> m ()
+workerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
+  forM_ tmpPath removePath
+  withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
+  notifyInternalError c rcvFileEntityId 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@AgentClient {subQ} doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    runXftpOperation
+  where
+    runXftpOperation :: m ()
+    runXftpOperation = do
+      nextFile <- withStore' c getNextRcvFileToDecrypt
+      case nextFile of
+        Nothing -> noWorkToDo
+        Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
+          decryptFile f `catchError` (workerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    decryptFile :: RcvFile -> m ()
+    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 >> createEmptyFile savePath)
+      withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
+      chunkPaths <- getChunkPaths chunks
+      encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure savePath
+      forM_ tmpPath removePath
+      withStore' c (`updateRcvFileComplete` rcvFileId)
+      notify $ RFDONE savePath
+      where
+        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+        notify cmd = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC (sAEntity @e) cmd)
+        getChunkPaths :: [RcvFileChunk] -> m [FilePath]
+        getChunkPaths [] = pure []
+        getChunkPaths (RcvFileChunk {chunkTmpPath = Just path} : cs) = do
+          ps <- getChunkPaths cs
+          pure $ path : ps
+        getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
+          throwError $ INTERNAL "no chunk path"
+
+deleteRcvFile :: AgentMonad m => AgentClient -> UserId -> RcvFileId -> m ()
+deleteRcvFile c userId rcvFileEntityId = do
+  RcvFile {rcvFileId, prefixPath, status} <- withStore c $ \db -> getRcvFileByEntityId db userId rcvFileEntityId
+  if status == RFSComplete || status == RFSError
+    then do
+      removePath prefixPath
+      withStore' c (`deleteRcvFile'` rcvFileId)
+    else withStore' c (`updateRcvFileDeleted` rcvFileId)
+
+sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId
+sendFileExperimental AgentClient {subQ, xftpServers} userId filePath numRecipients xftpWorkPath = do
+  g <- asks idsDrg
+  sndFileId <- liftIO $ randomId g 12
+  xftpSrvs <- atomically $ TM.lookup userId xftpServers
+  void $ forkIO $ sendCLI sndFileId $ maybe [] L.toList xftpSrvs
+  pure sndFileId
+  where
+    randomId :: TVar ChaChaDRG -> Int -> IO ByteString
+    randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
+    sendCLI :: SndFileId -> [XFTPServerWithAuth] -> m ()
+    sendCLI sndFileId xftpSrvs = do
+      let fileName = takeFileName filePath
+      workPath <- maybe getTemporaryDirectory pure xftpWorkPath
+      outputDir <- uniqueCombine workPath $ fileName <> ".descr"
+      createDirectory outputDir
+      let tempPath = workPath </> "snd"
+      createDirectoryIfMissing False tempPath
+      let sendOptions =
+            SendOptions
+              { filePath,
+                outputDir = Just outputDir,
+                numRecipients,
+                xftpServers = xftpSrvs,
+                retryCount = 3,
+                tempPath = Just tempPath,
+                verbose = False
+              }
+      liftCLI $ cliSendFile sendOptions
+      (sndDescr, rcvDescrs) <- readDescrs outputDir fileName
+      notify sndFileId $ SFDONE sndDescr rcvDescrs
+    liftCLI :: ExceptT CLIError IO () -> m ()
+    liftCLI = either (throwError . INTERNAL . show) pure <=< liftIO . runExceptT
+    readDescrs :: FilePath -> FilePath -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
+    readDescrs outDir fileName = do
+      let descrDir = outDir </> (fileName <> ".xftp")
+      files <- listDirectory descrDir
+      let (sdFiles, rdFiles) = partition ("snd.xftp.private" `isSuffixOf`) files
+          sdFile = maybe "" (\l -> descrDir </> L.head l) (nonEmpty sdFiles)
+          rdFiles' = map (descrDir </>) rdFiles
+      (,) <$> readDescr sdFile <*> mapM readDescr rdFiles'
+    readDescr :: FilePartyI p => FilePath -> m (ValidFileDescription p)
+    readDescr f = liftIOEither $ first INTERNAL . strDecode <$> B.readFile f
+    notify :: forall e. AEntityI e => SndFileId -> ACommand 'Agent e -> m ()
+    notify sndFileId cmd = atomically $ writeTBQueue subQ ("", sndFileId, APC (sAEntity @e) cmd)
+
+-- _sendFile :: AgentMonad m => AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId
+_sendFile :: AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId
+_sendFile _c _userId _numRecipients _xftpPath _filePath = do
+  -- db: create file in status New without chunks
+  -- add local snd worker for encryption
+  -- return file id to client
+  undefined
+
+_runXFTPSndLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+_runXFTPSndLocalWorker _c doWork = do
+  forever $ do
+    void . atomically $ readTMVar doWork
+    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
+
+_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
+    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

src/Simplex/FileTransfer/Client.hs

@@ -0,0 +1,212 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.FileTransfer.Client where
+
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import Data.ByteString.Builder (Builder, byteString)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Time (UTCTime)
+import Data.Word (Word32)
+import qualified Network.HTTP.Types as N
+import qualified Network.HTTP2.Client as H
+import Simplex.FileTransfer.Description (mb)
+import Simplex.FileTransfer.Protocol
+import Simplex.FileTransfer.Transport
+import Simplex.Messaging.Client
+  ( NetworkConfig (..),
+    ProtocolClientError (..),
+    TransportSession,
+    chooseTransportHost,
+    defaultNetworkConfig,
+    proxyUsername,
+    transportClientConfig,
+  )
+import Simplex.Messaging.Client.Agent ()
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol
+  ( BasicAuth,
+    Protocol (..),
+    ProtocolServer (..),
+    RecipientId,
+    SenderId,
+  )
+import Simplex.Messaging.Transport (supportedParameters)
+import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
+import Simplex.Messaging.Transport.HTTP2
+import Simplex.Messaging.Transport.HTTP2.Client
+import Simplex.Messaging.Util (bshow, liftEitherError, whenM)
+import UnliftIO
+import UnliftIO.Directory
+
+data XFTPClient = XFTPClient
+  { http2Client :: HTTP2Client,
+    transportSession :: TransportSession FileResponse,
+    config :: XFTPClientConfig
+  }
+
+data XFTPClientConfig = XFTPClientConfig
+  { xftpNetworkConfig :: NetworkConfig,
+    uploadTimeoutPerMb :: Int
+  }
+
+data XFTPChunkBody = XFTPChunkBody
+  { chunkSize :: Int,
+    chunkPart :: Int -> IO ByteString,
+    http2Body :: HTTP2Body
+  }
+
+data XFTPChunkSpec = XFTPChunkSpec
+  { filePath :: FilePath,
+    chunkOffset :: Int64,
+    chunkSize :: Word32
+  }
+  deriving (Eq, Show)
+
+type XFTPClientError = ProtocolClientError XFTPErrorType
+
+defaultXFTPClientConfig :: XFTPClientConfig
+defaultXFTPClientConfig =
+  XFTPClientConfig
+    { xftpNetworkConfig = defaultNetworkConfig,
+      uploadTimeoutPerMb = 10000000 -- 10 seconds
+    }
+
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig} disconnected = runExceptT $ do
+  let tcConfig = transportClientConfig xftpNetworkConfig
+      http2Config = xftpHTTP2Config tcConfig config
+      username = proxyUsername transportSession
+      ProtocolServer _ host port keyHash = srv
+  useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
+  clientVar <- newTVarIO Nothing
+  let usePort = if null port then "443" else port
+      clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
+  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
+  let c = XFTPClient {http2Client, transportSession, config}
+  atomically $ writeTVar clientVar $ Just c
+  pure c
+
+closeXFTPClient :: XFTPClient -> IO ()
+closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client
+
+xftpClientServer :: XFTPClient -> String
+xftpClientServer = B.unpack . strEncode . snd3 . transportSession
+  where
+    snd3 (_, s, _) = s
+
+xftpTransportHost :: XFTPClient -> TransportHost
+xftpTransportHost = (host :: HClient -> TransportHost) . client_ . http2Client
+
+xftpSessionTs :: XFTPClient -> UTCTime
+xftpSessionTs = sessionTs . http2Client
+
+xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig
+xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} =
+  defaultHTTP2ClientConfig
+    { bodyHeadSize = xftpBlockSize,
+      suportedTLSParams = supportedParameters,
+      connTimeout = tcpConnectTimeout,
+      transportConfig
+    }
+
+xftpClientError :: HTTP2ClientError -> XFTPClientError
+xftpClientError = \case
+  HCResponseTimeout -> PCEResponseTimeout
+  HCNetworkError -> PCENetworkError
+  HCIOError e -> PCEIOError e
+
+sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
+sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
+  t <-
+    liftEither . first PCETransportError $
+      xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
+  let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
+      reqTimeout = (\XFTPChunkSpec {chunkSize} -> (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1) <$> chunkSpec_
+  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
+  when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
+  -- TODO validate that the file ID is the same as in the request?
+  (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead
+  case respOrErr of
+    Right r -> case protocolError r of
+      Just e -> throwError $ PCEProtocolError e
+      _ -> pure (r, body)
+    Left e -> throwError $ PCEResponseError e
+  where
+    streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
+    streamBody t send done = do
+      send $ byteString t
+      forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
+        withFile filePath ReadMode $ \h -> do
+          hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+          sendFile h send $ fromIntegral chunkSize
+      done
+
+createXFTPChunk ::
+  XFTPClient ->
+  C.APrivateSignKey ->
+  FileInfo ->
+  NonEmpty C.APublicVerifyKey ->
+  Maybe BasicAuth ->
+  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
+createXFTPChunk c spKey file rsps auth_ =
+  sendXFTPCommand c spKey "" (FNEW file rsps auth_) Nothing >>= \case
+    (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
+    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
+uploadXFTPChunk c spKey fId chunkSpec =
+  sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
+
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
+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 = _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
+        cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
+        let t = (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1
+        t `timeout` download cbState >>= maybe (throwError PCEResponseTimeout) pure
+        where
+          download cbState =
+            withExceptT PCEResponseError $
+              receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
+                whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
+      _ -> throwError $ PCEResponseError NO_FILE
+    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO ()
+deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
+
+ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO ()
+ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse
+
+okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO ()
+okResponse = \case
+  (FROk, body) -> noFile body ()
+  (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+-- TODO this currently does not check anything because response size is not set and bodyPart is always Just
+noFile :: HTTP2Body -> a -> ExceptT XFTPClientError IO a
+noFile HTTP2Body {bodyPart} a = case bodyPart of
+  Just _ -> pure a -- throwError $ PCEResponseError HAS_FILE
+  _ -> pure a
+
+-- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
+-- FDEL :: FileCommand Sender
+-- FACK :: FileCommand Recipient
+-- PING :: FileCommand Recipient

src/Simplex/FileTransfer/Client/Agent.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Client.Agent where
+
+import Control.Logger.Simple (logInfo)
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Char8 as B
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Simplex.FileTransfer.Client
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
+import Simplex.Messaging.Client.Agent ()
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (catchAll_, tryError)
+import UnliftIO
+
+type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
+
+data XFTPClientAgent = XFTPClientAgent
+  { xftpClients :: TMap XFTPServer XFTPClientVar,
+    config :: XFTPClientAgentConfig
+  }
+
+data XFTPClientAgentConfig = XFTPClientAgentConfig
+  { xftpConfig :: XFTPClientConfig,
+    reconnectInterval :: RetryInterval
+  }
+
+defaultXFTPClientAgentConfig :: XFTPClientAgentConfig
+defaultXFTPClientAgentConfig =
+  XFTPClientAgentConfig
+    { xftpConfig = defaultXFTPClientConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = 5_000000,
+            increaseAfter = 10_000000,
+            maxInterval = 60_000000
+          }
+    }
+
+data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
+  deriving (Show, Exception)
+
+newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent
+newXFTPAgent config = do
+  xftpClients <- TM.empty
+  pure XFTPClientAgent {xftpClients, config}
+
+type ME a = ExceptT XFTPClientAgentError IO a
+
+getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
+getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
+  atomically getClientVar >>= either newXFTPClient waitForXFTPClient
+  where
+    connectClient :: ME XFTPClient
+    connectClient =
+      ExceptT $
+        first (XFTPClientAgentError srv)
+          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
+
+    clientDisconnected :: XFTPClient -> IO ()
+    clientDisconnected _ = do
+      atomically $ TM.delete srv xftpClients
+      logInfo $ "disconnected from " <> showServer srv
+
+    getClientVar :: STM (Either XFTPClientVar XFTPClientVar)
+    getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv xftpClients
+      where
+        newClientVar :: STM XFTPClientVar
+        newClientVar = do
+          var <- newEmptyTMVar
+          TM.insert srv var xftpClients
+          pure var
+
+    waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
+    waitForXFTPClient clientVar = do
+      let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
+      client_ <- tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
+      liftEither $ case client_ of
+        Just (Right c) -> Right c
+        Just (Left e) -> Left e
+        Nothing -> Left $ XFTPClientAgentError srv PCEResponseTimeout
+
+    newXFTPClient :: XFTPClientVar -> ME XFTPClient
+    newXFTPClient clientVar = tryConnectClient tryConnectAsync
+      where
+        tryConnectClient :: ME () -> ME XFTPClient
+        tryConnectClient retryAction =
+          tryError connectClient >>= \r -> case r of
+            Right client -> do
+              logInfo $ "connected to " <> showServer srv
+              atomically $ putTMVar clientVar r
+              pure client
+            Left e@(XFTPClientAgentError _ e') -> do
+              if temporaryClientError e'
+                then retryAction
+                else atomically $ do
+                  putTMVar clientVar r
+                  TM.delete srv xftpClients
+              throwError e
+        tryConnectAsync :: ME ()
+        tryConnectAsync = void . async $ do
+          withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop
+
+showServer :: XFTPServer -> Text
+showServer ProtocolServer {host, port} =
+  decodeUtf8 $ strEncode host <> B.pack (if null port then "" else ':' : port)
+
+closeXFTPServerClient :: XFTPClientAgent -> XFTPServer -> IO ()
+closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
+  atomically (TM.lookupDelete srv xftpClients) >>= mapM_ closeClient
+  where
+    closeClient cVar = do
+      let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
+      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+        Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
+        _ -> pure ()

src/Simplex/FileTransfer/Client/Main.hs

@@ -0,0 +1,587 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.FileTransfer.Client.Main
+  ( SendOptions (..),
+    CLIError (..),
+    xftpClientCLI,
+    cliSendFile,
+    prepareChunkSizes,
+  )
+where
+
+import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple
+import Control.Monad
+import Control.Monad.Except
+import Crypto.Random (getRandomBytes)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Char (toLower)
+import Data.Function (on)
+import Data.Int (Int64)
+import Data.List (foldl', groupBy, sortOn)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import qualified Data.List.NonEmpty as L
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Word (Word32)
+import GHC.Records (HasField (getField))
+import Options.Applicative
+import Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Client.Agent
+import Simplex.FileTransfer.Client.Presets
+import Simplex.FileTransfer.Crypto
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Types
+import Simplex.FileTransfer.Util (uniqueCombine)
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth)
+import Simplex.Messaging.Server.CLI (getCliCommand')
+import Simplex.Messaging.Util (ifM, tshow, whenM)
+import System.Exit (exitFailure)
+import System.FilePath (splitFileName, (</>))
+import System.IO.Temp (getCanonicalTemporaryDirectory)
+import System.Random (StdGen, newStdGen, randomR)
+import UnliftIO
+import UnliftIO.Directory
+
+xftpClientVersion :: String
+xftpClientVersion = "0.1.0"
+
+chunkSize1 :: Word32
+chunkSize1 = kb 256
+
+chunkSize2 :: Word32
+chunkSize2 = mb 1
+
+chunkSize3 :: Word32
+chunkSize3 = mb 4
+
+maxFileSize :: Int64
+maxFileSize = gb 1
+
+maxFileSizeStr :: String
+maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize
+
+fileSizeLen :: Int64
+fileSizeLen = 8
+
+newtype CLIError = CLIError String
+  deriving (Eq, Show, Exception)
+
+cliCryptoError :: FTCryptoError -> CLIError
+cliCryptoError = \case
+  FTCECryptoError e -> CLIError $ "Error decrypting file: " <> show e
+  FTCEInvalidHeader e -> CLIError $ "Invalid file header: " <> e
+  FTCEInvalidAuthTag -> CLIError "Error decrypting file: incorrect auth tag"
+  FTCEFileIOError e -> CLIError $ "File IO error: " <> show e
+
+data CliCommand
+  = SendFile SendOptions
+  | ReceiveFile ReceiveOptions
+  | DeleteFile DeleteOptions
+  | RandomFile RandomFileOptions
+  | FileDescrInfo InfoOptions
+
+data SendOptions = SendOptions
+  { filePath :: FilePath,
+    outputDir :: Maybe FilePath,
+    numRecipients :: Int,
+    xftpServers :: [XFTPServerWithAuth],
+    retryCount :: Int,
+    tempPath :: Maybe FilePath,
+    verbose :: Bool
+  }
+  deriving (Show)
+
+data ReceiveOptions = ReceiveOptions
+  { fileDescription :: FilePath,
+    filePath :: Maybe FilePath,
+    retryCount :: Int,
+    tempPath :: Maybe FilePath,
+    verbose :: Bool,
+    yes :: Bool
+  }
+  deriving (Show)
+
+data DeleteOptions = DeleteOptions
+  { fileDescription :: FilePath,
+    retryCount :: Int,
+    verbose :: Bool,
+    yes :: Bool
+  }
+  deriving (Show)
+
+newtype InfoOptions = InfoOptions
+  { fileDescription :: FilePath
+  }
+  deriving (Show)
+
+data RandomFileOptions = RandomFileOptions
+  { filePath :: FilePath,
+    fileSize :: FileSize Int
+  }
+  deriving (Show)
+
+defaultRetryCount :: Int
+defaultRetryCount = 3
+
+cliCommandP :: Parser CliCommand
+cliCommandP =
+  hsubparser
+    ( command "send" (info (SendFile <$> sendP) (progDesc "Send file"))
+        <> command "recv" (info (ReceiveFile <$> receiveP) (progDesc "Receive file"))
+        <> command "del" (info (DeleteFile <$> deleteP) (progDesc "Delete file from server(s)"))
+        <> command "info" (info (FileDescrInfo <$> infoP) (progDesc "Show file description"))
+    )
+    <|> hsubparser (command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size")) <> internal)
+  where
+    sendP :: Parser SendOptions
+    sendP =
+      SendOptions
+        <$> argument str (metavar "FILE" <> help "File to send")
+        <*> optional (argument str $ metavar "DIR" <> help "Directory to save file descriptions (default: current directory)")
+        <*> option auto (short 'n' <> metavar "COUNT" <> help "Number of recipients" <> value 1 <> showDefault)
+        <*> xftpServers
+        <*> retryCountP
+        <*> temp
+        <*> verboseP
+    receiveP :: Parser ReceiveOptions
+    receiveP =
+      ReceiveOptions
+        <$> fileDescrArg
+        <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
+        <*> retryCountP
+        <*> temp
+        <*> verboseP
+        <*> yesP
+    deleteP :: Parser DeleteOptions
+    deleteP =
+      DeleteOptions
+        <$> fileDescrArg
+        <*> retryCountP
+        <*> verboseP
+        <*> yesP
+    infoP :: Parser InfoOptions
+    infoP = InfoOptions <$> fileDescrArg
+    randomP :: Parser RandomFileOptions
+    randomP =
+      RandomFileOptions
+        <$> argument str (metavar "FILE" <> help "Path to save file")
+        <*> argument str (metavar "SIZE" <> help "File size (bytes/kb/mb/gb)")
+    fileDescrArg = argument str (metavar "FILE" <> help "File description file")
+    retryCountP = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
+    temp = optional (strOption $ long "tmp" <> metavar "TMP" <> help "Directory for temporary encrypted file (default: system temp directory)")
+    verboseP = switch (long "verbose" <> short 'v' <> help "Verbose output")
+    yesP = switch (long "yes" <> short 'y' <> help "Yes to questions")
+    xftpServers =
+      option
+        parseXFTPServers
+        ( long "servers"
+            <> short 's'
+            <> metavar "SERVER"
+            <> help "Semicolon-separated list of XFTP server(s) to use (each server can have more than one hostname)"
+            <> value []
+        )
+    parseXFTPServers = eitherReader $ parseAll xftpServersP . B.pack
+    xftpServersP = strP `A.sepBy1` A.char ';'
+
+data SentFileChunk = SentFileChunk
+  { chunkNo :: Int,
+    sndId :: SenderId,
+    sndPrivateKey :: SndPrivateSignKey,
+    chunkSize :: FileSize Word32,
+    digest :: FileDigest,
+    replicas :: [SentFileChunkReplica]
+  }
+  deriving (Eq, Show)
+
+data SentFileChunkReplica = SentFileChunkReplica
+  { server :: XFTPServer,
+    recipients :: [(ChunkReplicaId, C.APrivateSignKey)]
+  }
+  deriving (Eq, Show)
+
+data SentRecipientReplica = SentRecipientReplica
+  { chunkNo :: Int,
+    server :: XFTPServer,
+    rcvNo :: Int,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    digest :: FileDigest,
+    chunkSize :: FileSize Word32
+  }
+
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
+xftpClientCLI :: IO ()
+xftpClientCLI =
+  getCliCommand' cliCommandP clientVersion >>= \case
+    SendFile opts -> runLogE opts $ cliSendFile opts
+    ReceiveFile opts -> runLogE opts $ cliReceiveFile opts
+    DeleteFile opts -> runLogE opts $ cliDeleteFile opts
+    FileDescrInfo opts -> runE $ cliFileDescrInfo opts
+    RandomFile opts -> cliRandomFile opts
+  where
+    clientVersion = "SimpleX XFTP client v" <> xftpClientVersion
+
+runLogE :: HasField "verbose" a Bool => a -> ExceptT CLIError IO () -> IO ()
+runLogE opts a
+  | getField @"verbose" opts = setLogLevel LogDebug >> withGlobalLogging logCfg (runE a)
+  | otherwise = runE a
+
+runE :: ExceptT CLIError IO () -> IO ()
+runE a =
+  runExceptT a >>= \case
+    Left (CLIError e) -> putStrLn e >> exitFailure
+    _ -> pure ()
+
+cliSendFile :: SendOptions -> ExceptT CLIError IO ()
+cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} = do
+  let (_, fileName) = splitFileName filePath
+  liftIO $ printNoNewLine "Encrypting file..."
+  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName
+  liftIO $ printNoNewLine "Uploading file..."
+  uploadedChunks <- newTVarIO []
+  sentChunks <- uploadFile chunkSpecs uploadedChunks encSize
+  whenM (doesFileExist encPath) $ removeFile encPath
+  -- TODO if only small chunks, use different default size
+  liftIO $ do
+    let fdRcvs = createRcvFileDescriptions fdRcv sentChunks
+        fdSnd' = createSndFileDescription fdSnd sentChunks
+    (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd'
+    printNoNewLine "File uploaded!"
+    putStrLn $ "\nSender file description: " <> fdSndPath
+    putStrLn "Pass file descriptions to the recipient(s):"
+    forM_ fdRcvPaths putStrLn
+  where
+    encryptFileForUpload :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
+    encryptFileForUpload fileName = do
+      fileSize <- fromInteger <$> getFileSize filePath
+      when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
+      encPath <- getEncPath tempPath "xftp"
+      key <- liftIO C.randomSbKey
+      nonce <- liftIO C.randomCbNonce
+      let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
+          fileSize' = fromIntegral (B.length fileHdr) + fileSize
+          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
+          defChunkSize = head chunkSizes
+          chunkSizes' = map fromIntegral chunkSizes
+          encSize = sum chunkSizes'
+      withExceptT (CLIError . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize encPath
+      digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
+      let chunkSpecs = prepareChunkSpecs encPath chunkSizes
+          fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+          fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+      logInfo $ "encrypted file to " <> tshow encPath
+      pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
+    uploadFile :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
+    uploadFile chunks uploadedChunks encSize = do
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      gen <- newTVarIO =<< liftIO newStdGen
+      let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers)
+      srvs <- liftIO $ replicateM (length chunks) $ getXFTPServer gen xftpSrvs
+      let thd3 (_, _, x) = x
+          chunks' = groupBy ((==) `on` thd3) $ sortOn thd3 $ zip3 [1 ..] chunks srvs
+      -- TODO shuffle/unshuffle chunks
+      -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
+      -- upload doesn't allow other requests within the same client until complete (but download does allow).
+      logInfo $ "uploading " <> tshow (length chunks) <> " chunks..."
+      map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 chunks' (mapM $ uploadFileChunk a)
+      where
+        uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
+        uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
+          logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
+          (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+          rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
+          ch@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
+          c <- withRetry retryCount $ getXFTPServerClient a xftpServer
+          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
+          withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
+          logInfo $ "uploaded chunk " <> tshow chunkNo
+          uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
+            let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
+          liftIO $ do
+            printProgress "Uploaded" uploaded encSize
+            when verbose $ putStrLn ""
+          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
+          servers -> do
+            atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
+
+    -- M chunks, R replicas, N recipients
+    -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
+    -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
+    createRcvFileDescriptions :: FileDescription 'FRecipient -> [SentFileChunk] -> [FileDescription 'FRecipient]
+    createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
+      where
+        rcvReplicas :: [SentRecipientReplica]
+        rcvReplicas =
+          concatMap
+            ( \SentFileChunk {chunkNo, digest, chunkSize, replicas} ->
+                concatMap
+                  ( \SentFileChunkReplica {server, recipients} ->
+                      zipWith (\rcvNo (replicaId, replicaKey) -> SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize}) [1 ..] recipients
+                  )
+                  replicas
+            )
+            sentChunks
+        rcvChunks :: [[FileChunk]]
+        rcvChunks = map (sortChunks . M.elems) $ M.elems $ foldl' addRcvChunk M.empty rcvReplicas
+        sortChunks :: [FileChunk] -> [FileChunk]
+        sortChunks = map reverseReplicas . sortOn (chunkNo :: FileChunk -> Int)
+        reverseReplicas ch@FileChunk {replicas} = (ch :: FileChunk) {replicas = reverse replicas}
+        addRcvChunk :: Map Int (Map Int FileChunk) -> SentRecipientReplica -> Map Int (Map Int FileChunk)
+        addRcvChunk m SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize} =
+          M.alter (Just . addOrChangeRecipient) rcvNo m
+          where
+            addOrChangeRecipient :: Maybe (Map Int FileChunk) -> Map Int FileChunk
+            addOrChangeRecipient = \case
+              Just m' -> M.alter (Just . addOrChangeChunk) chunkNo m'
+              _ -> M.singleton chunkNo $ FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
+            addOrChangeChunk :: Maybe FileChunk -> FileChunk
+            addOrChangeChunk = \case
+              Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas}
+              _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
+            replica = FileChunkReplica {server, replicaId, replicaKey}
+    createSndFileDescription :: FileDescription 'FSender -> [SentFileChunk] -> FileDescription 'FSender
+    createSndFileDescription fd sentChunks = fd {chunks = sndChunks}
+      where
+        sndChunks :: [FileChunk]
+        sndChunks =
+          map
+            ( \SentFileChunk {chunkNo, sndId, sndPrivateKey, chunkSize, digest, replicas} ->
+                FileChunk {chunkNo, digest, chunkSize, replicas = sndReplicas replicas (ChunkReplicaId sndId) sndPrivateKey}
+            )
+            sentChunks
+        -- SentFileChunk having sndId and sndPrivateKey represents the current implementation's limitation
+        -- that sender uploads each chunk only to one server, so we can use the first replica's server for FileChunkReplica
+        sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica]
+        sndReplicas [] _ _ = []
+        sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}]
+    writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath)
+    writeFileDescriptions fileName fdRcvs fdSnd = do
+      outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
+      createDirectoryIfMissing True outDir
+      fdRcvPaths <- forM (zip [1 ..] fdRcvs) $ \(i :: Int, fd) -> do
+        let fdPath = outDir </> ("rcv" <> show i <> ".xftp")
+        B.writeFile fdPath $ strEncode fd
+        pure fdPath
+      let fdSndPath = outDir </> "snd.xftp.private"
+      B.writeFile fdSndPath $ strEncode fdSnd
+      pure (fdRcvPaths, fdSndPath)
+
+cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
+cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
+  getFileDescription' fileDescription >>= receiveFile
+  where
+    receiveFile :: ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
+    receiveFile (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do
+      encPath <- getEncPath tempPath "xftp"
+      createDirectory encPath
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      liftIO $ printNoNewLine "Downloading file..."
+      downloadedChunks <- newTVarIO []
+      let srv FileChunk {replicas} = server (head replicas :: FileChunkReplica)
+          srvChunks = groupBy ((==) `on` srv) $ sortOn srv chunks
+      chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks)
+      encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
+      when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
+      encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
+      liftIO $ printNoNewLine "Decrypting file..."
+      path <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath
+      forM_ chunks $ acknowledgeFileChunk a
+      whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
+      liftIO $ do
+        printNoNewLine $ "File downloaded: " <> path
+        removeFD yes fileDescription
+    downloadFileChunk :: XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
+    downloadFileChunk a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
+      logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
+      chunkPath <- uniqueCombine encPath $ show chunkNo
+      let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
+      withReconnect a server retryCount $ \c -> downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
+      downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
+        let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
+      liftIO $ do
+        printProgress "Downloaded" downloaded encSize
+        when verbose $ putStrLn ""
+      pure (chunkNo, chunkPath)
+    downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
+    getFilePath :: String -> ExceptT String IO FilePath
+    getFilePath name =
+      case filePath of
+        Just path ->
+          ifM (doesDirectoryExist path) (uniqueCombine path name) $
+            ifM (doesFileExist path) (throwError "File already exists") (pure path)
+        _ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
+    acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
+    acknowledgeFileChunk a FileChunk {replicas = replica : _} = do
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
+      c <- withRetry retryCount $ getXFTPServerClient a server
+      withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+    acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
+
+printProgress :: String -> Int64 -> Int64 -> IO ()
+printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%"
+
+printNoNewLine :: String -> IO ()
+printNoNewLine s = do
+  putStr $ s <> replicate (max 0 $ 25 - length s) ' ' <> "\r"
+  hFlush stdout
+
+cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
+cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
+  getFileDescription' fileDescription >>= deleteFile
+  where
+    deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO ()
+    deleteFile (ValidFileDescription FileDescription {chunks}) = do
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      forM_ chunks $ deleteFileChunk a
+      liftIO $ do
+        printNoNewLine "File deleted!"
+        removeFD yes fileDescription
+    deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
+    deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
+      withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+      logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
+    deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
+
+cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
+cliFileDescrInfo InfoOptions {fileDescription} = do
+  getFileDescription fileDescription >>= \case
+    AVFD (ValidFileDescription FileDescription {party, size, chunkSize, chunks}) -> do
+      let replicas = groupReplicasByServer chunkSize chunks
+      liftIO $ do
+        printParty
+        putStrLn $ "File download size: " <> strEnc size
+        putStrLn "File server(s):"
+        forM_ replicas $ \srvReplicas -> do
+          let srv = replicaServer $ head srvReplicas
+              chSizes = map (\FileServerReplica {chunkSize = chSize_} -> unFileSize $ fromMaybe chunkSize chSize_) srvReplicas
+          putStrLn $ strEnc srv <> ": " <> strEnc (FileSize $ sum chSizes)
+      where
+        printParty :: IO ()
+        printParty = case party of
+          SFRecipient -> putStrLn "Recipient file description"
+          SFSender -> putStrLn "Sender file description"
+
+strEnc :: StrEncoding a => a -> String
+strEnc = B.unpack . strEncode
+
+getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription
+getFileDescription path =
+  ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
+
+getFileDescription' :: FilePartyI p => FilePath -> ExceptT CLIError IO (ValidFileDescription p)
+getFileDescription' path =
+  getFileDescription path >>= \case
+    AVFD fd -> either (throwError . CLIError) pure $ checkParty fd
+
+prepareChunkSizes :: Int64 -> [Word32]
+prepareChunkSizes size' = prepareSizes size'
+  where
+    (smallSize, bigSize) = if size' > size34 chunkSize3 then (chunkSize2, chunkSize3) else (chunkSize1, chunkSize2)
+    size34 sz = (fromIntegral sz * 3) `div` 4
+    prepareSizes 0 = []
+    prepareSizes size
+      | size >= fromIntegral bigSize = replicate (fromIntegral n1) bigSize <> prepareSizes remSz
+      | size > size34 bigSize = [bigSize]
+      | otherwise = replicate (fromIntegral n2') smallSize
+      where
+        (n1, remSz) = size `divMod` fromIntegral bigSize
+        n2' = let (n2, remSz2) = (size `divMod` fromIntegral smallSize) in if remSz2 == 0 then n2 else n2 + 1
+
+prepareChunkSpecs :: FilePath -> [Word32] -> [XFTPChunkSpec]
+prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) chunkSizes
+  where
+    addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec])
+    addSpec (chunkOffset, specs) sz =
+      let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = fromIntegral sz}
+       in (chunkOffset + fromIntegral sz, spec : specs)
+
+getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
+getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path
+
+withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
+withReconnect a srv n run = withRetry n $ do
+  c <- withRetry n $ getXFTPServerClient a srv
+  withExceptT (CLIError . show) (run c) `catchError` \e -> do
+    liftIO $ closeXFTPServerClient a srv
+    throwError e
+
+withRetry :: Show e => Int -> ExceptT e IO a -> ExceptT CLIError IO a
+withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
+  where
+    withRetry' :: Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
+    withRetry' 0 _ = throwError $ CLIError "internal: no retry attempts"
+    withRetry' 1 a = a
+    withRetry' n a =
+      a `catchError` \e -> do
+        logWarn ("retrying: " <> tshow e)
+        withRetry' (n - 1) a
+
+removeFD :: Bool -> FilePath -> IO ()
+removeFD yes fd
+  | yes = do
+    removeFile fd
+    putStrLn $ "\nFile description " <> fd <> " is deleted."
+  | otherwise = do
+    y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it"
+    when y $ removeFile fd
+
+getConfirmation :: String -> IO Bool
+getConfirmation prompt = do
+  putStr $ prompt <> " (Y/n): "
+  hFlush stdout
+  s <- getLine
+  case map toLower s of
+    "y" -> pure True
+    "" -> pure True
+    "n" -> pure False
+    _ -> getConfirmation prompt
+
+cliRandomFile :: RandomFileOptions -> IO ()
+cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
+  withFile filePath WriteMode (`saveRandomFile` size)
+  putStrLn $ "File created: " <> filePath
+  where
+    saveRandomFile h sz = do
+      bytes <- getRandomBytes $ min mb' sz
+      B.hPut h bytes
+      when (sz > mb') $ saveRandomFile h (sz - mb')
+    mb' = mb 1

src/Simplex/FileTransfer/Client/Presets.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Client.Presets where
+
+import Data.List.NonEmpty (NonEmpty)
+import Simplex.Messaging.Protocol (XFTPServerWithAuth)
+
+defaultXFTPServers :: NonEmpty XFTPServerWithAuth
+defaultXFTPServers =
+  [ "xftp://da1aH3nOT-9G8lV7bWamhxpDYdJ1xmW7j3JpGaDR5Ug=@xftp1.simplex.im",
+    "xftp://5vog2Imy1ExJB_7zDZrkV1KDWi96jYFyy9CL6fndBVw=@xftp2.simplex.im",
+    "xftp://PYa32DdYNFWi0uZZOprWQoQpIk5qyjRJ3EF7bVpbsn8=@xftp3.simplex.im",
+    "xftp://k_GgQl40UZVV0Y4BX9ZTyMVqX5ZewcLW0waQIl7AYDE=@xftp4.simplex.im",
+    "xftp://-bIo6o8wuVc4wpZkZD3tH-rCeYaeER_0lz1ffQcSJDs=@xftp5.simplex.im",
+    "xftp://6nSvtY9pJn6PXWTAIMNl95E1Kk1vD7FM2TeOA64CFLg=@xftp6.simplex.im"
+  ]

src/Simplex/FileTransfer/Crypto.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Crypto where
+
+import Control.Monad.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import qualified Data.ByteArray as BA
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Simplex.FileTransfer.Types (FileHeader (..), authTagSize)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Lazy (LazyByteString)
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Util (liftEitherWith)
+import UnliftIO
+import UnliftIO.Directory (removeFile)
+
+encryptFile :: FilePath -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
+encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do
+  sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
+  withFile filePath ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
+    let lenStr = smpEncode fileSize'
+        (hdr, !sb') = LC.sbEncryptChunk sb $ lenStr <> fileHdr
+        padLen = encSize - authTagSize - fileSize' - 8
+    liftIO $ B.hPut w hdr
+    sb2 <- encryptChunks r w (sb', fileSize' - fromIntegral (B.length fileHdr))
+    sb3 <- encryptPad w (sb2, padLen)
+    let tag = BA.convert $ LC.sbAuth sb3
+    liftIO $ B.hPut w tag
+  where
+    encryptChunks r = encryptChunks_ $ liftIO . B.hGet r . fromIntegral
+    encryptPad = encryptChunks_ $ \sz -> pure $ B.replicate (fromIntegral sz) '#'
+    encryptChunks_ :: (Int64 -> IO ByteString) -> Handle -> (LC.SbState, Int64) -> ExceptT FTCryptoError IO LC.SbState
+    encryptChunks_ get w (!sb, !len)
+      | len == 0 = pure sb
+      | otherwise = do
+        let chSize = min len 65536
+        ch <- liftIO $ get chSize
+        when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
+        let (ch', sb') = LC.sbEncryptChunk sb ch
+        liftIO $ B.hPut w ch'
+        encryptChunks_ get w (sb', len - chSize)
+
+decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath
+decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"
+decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse chPaths of
+  [] -> do
+    (!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath)
+    unless authOk $ throwError FTCEInvalidAuthTag
+    (FileHeader {fileName}, !f') <- parseFileHeader f
+    path <- withExceptT FTCEFileIOError $ getFilePath fileName
+    liftIO $ LB.writeFile path f'
+    pure path
+  lastPath : chPaths' -> do
+    (state, expectedLen, ch) <- decryptFirstChunk
+    (FileHeader {fileName}, ch') <- parseFileHeader ch
+    path <- withExceptT FTCEFileIOError $ getFilePath fileName
+    authOk <- liftIO . withFile path WriteMode $ \h -> do
+      liftIO $ LB.hPut h ch'
+      state' <- foldM (decryptChunk h) state $ reverse chPaths'
+      decryptLastChunk h state' expectedLen
+    unless authOk $ do
+      removeFile path
+      throwError FTCEInvalidAuthTag
+    pure path
+    where
+      decryptFirstChunk = do
+        sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
+        ch <- liftIO $ LB.readFile chPath
+        let (ch1, !sb') = LC.sbDecryptChunkLazy sb ch
+        (!expectedLen, ch2) <- liftEitherWith FTCECryptoError $ LC.splitLen ch1
+        let len1 = LB.length ch2
+        pure ((sb', len1), expectedLen, ch2)
+      decryptChunk h (!sb, !len) chPth = do
+        ch <- LB.readFile chPth
+        let len' = len + LB.length ch
+            (ch', sb') = LC.sbDecryptChunkLazy sb ch
+        LB.hPut h ch'
+        pure (sb', len')
+      decryptLastChunk h (!sb, !len) expectedLen = do
+        ch <- LB.readFile lastPath
+        let (ch1, tag') = LB.splitAt (LB.length ch - authTagSize) ch
+            tag'' = LB.toStrict tag'
+            (ch2, sb') = LC.sbDecryptChunkLazy sb ch1
+            len' = len + LB.length ch2
+            ch3 = LB.take (LB.length ch2 - len' + expectedLen) ch2
+            tag :: ByteString = BA.convert (LC.sbAuth sb')
+        LB.hPut h ch3
+        pure $ B.length tag'' == 16 && BA.constEq tag'' tag
+  where
+    parseFileHeader :: LazyByteString -> ExceptT FTCryptoError IO (FileHeader, LazyByteString)
+    parseFileHeader s = do
+      let (hdrStr, s') = LB.splitAt 1024 s
+      case A.parse smpP $ LB.toStrict hdrStr of
+        A.Fail _ _ e -> throwError $ FTCEInvalidHeader e
+        A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete"
+        A.Done rest hdr -> pure (hdr, LB.fromStrict rest <> s')
+
+readChunks :: [FilePath] -> IO LB.ByteString
+readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
+
+data FTCryptoError
+  = FTCECryptoError C.CryptoError
+  | FTCEInvalidHeader String
+  | FTCEInvalidAuthTag
+  | FTCEFileIOError String
+  deriving (Show, Eq, Exception)

src/Simplex/FileTransfer/Description.hs

@@ -0,0 +1,361 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Description
+  ( FileDescription (..),
+    AFileDescription (..),
+    ValidFileDescription, -- constructor is not exported, use pattern
+    pattern ValidFileDescription,
+    AValidFileDescription (..),
+    FileDigest (..),
+    FileChunk (..),
+    FileChunkReplica (..),
+    FileServerReplica (..),
+    FileSize (..),
+    ChunkReplicaId (..),
+    YAMLFileDescription (..), -- for tests
+    YAMLServerReplicas (..), -- for tests
+    validateFileDescription,
+    groupReplicasByServer,
+    replicaServer,
+    fdSeparator,
+    kb,
+    mb,
+    gb,
+  )
+where
+
+import Control.Applicative (optional)
+import Control.Monad ((<=<))
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Function (on)
+import Data.Int (Int64)
+import Data.List (foldl', groupBy, sortOn)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.String
+import Data.Word (Word32)
+import qualified Data.Yaml as Y
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+import GHC.Generics (Generic)
+import Simplex.FileTransfer.Protocol
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (XFTPServer)
+import Simplex.Messaging.Util (bshow, (<$?>))
+
+data FileDescription (p :: FileParty) = FileDescription
+  { party :: SFileParty p,
+    size :: FileSize Int64,
+    digest :: FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: FileSize Word32,
+    chunks :: [FileChunk]
+  }
+  deriving (Eq, Show)
+
+data AFileDescription = forall p. FilePartyI p => AFD (FileDescription p)
+
+newtype ValidFileDescription p = ValidFD (FileDescription p)
+  deriving (Eq, Show)
+
+pattern ValidFileDescription :: FileDescription p -> ValidFileDescription p
+pattern ValidFileDescription fd = ValidFD fd
+
+{-# COMPLETE ValidFileDescription #-}
+
+data AValidFileDescription = forall p. FilePartyI p => AVFD (ValidFileDescription p)
+
+fdSeparator :: IsString s => s
+fdSeparator = "################################\n"
+
+newtype FileDigest = FileDigest {unFileDigest :: ByteString}
+  deriving (Eq, Show)
+
+instance StrEncoding FileDigest where
+  strEncode (FileDigest fd) = strEncode fd
+  strDecode s = FileDigest <$> strDecode s
+  strP = FileDigest <$> strP
+
+instance FromJSON FileDigest where
+  parseJSON = strParseJSON "FileDigest"
+
+instance ToJSON FileDigest where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromField FileDigest where fromField f = FileDigest <$> fromField f
+
+instance ToField FileDigest where toField (FileDigest s) = toField s
+
+data FileChunk = FileChunk
+  { chunkNo :: Int,
+    chunkSize :: FileSize Word32,
+    digest :: FileDigest,
+    replicas :: [FileChunkReplica]
+  }
+  deriving (Eq, Show)
+
+data FileChunkReplica = FileChunkReplica
+  { server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey
+  }
+  deriving (Eq, Show)
+
+newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: ByteString}
+  deriving (Eq, Show)
+
+instance StrEncoding ChunkReplicaId where
+  strEncode (ChunkReplicaId fid) = strEncode fid
+  strP = ChunkReplicaId <$> strP
+
+instance FromJSON ChunkReplicaId where
+  parseJSON = strParseJSON "ChunkReplicaId"
+
+instance ToJSON ChunkReplicaId where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromField ChunkReplicaId where fromField f = ChunkReplicaId <$> fromField f
+
+instance ToField ChunkReplicaId where toField (ChunkReplicaId s) = toField s
+
+data YAMLFileDescription = YAMLFileDescription
+  { party :: FileParty,
+    size :: String,
+    digest :: FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: String,
+    replicas :: [YAMLServerReplicas]
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON YAMLFileDescription where
+  toJSON = J.genericToJSON J.defaultOptions
+  toEncoding = J.genericToEncoding J.defaultOptions
+
+data YAMLServerReplicas = YAMLServerReplicas
+  { server :: XFTPServer,
+    chunks :: [String]
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON YAMLServerReplicas where
+  toJSON = J.genericToJSON J.defaultOptions
+  toEncoding = J.genericToEncoding J.defaultOptions
+
+data FileServerReplica = FileServerReplica
+  { chunkNo :: Int,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    digest :: Maybe FileDigest,
+    chunkSize :: Maybe (FileSize Word32)
+  }
+  deriving (Show)
+
+instance FilePartyI p => StrEncoding (ValidFileDescription p) where
+  strEncode (ValidFD fd) = strEncode fd
+  strDecode s = strDecode s >>= (\(AVFD fd) -> checkParty fd)
+  strP = strDecode <$?> A.takeByteString
+
+instance StrEncoding AValidFileDescription where
+  strEncode (AVFD fd) = strEncode fd
+  strDecode = validateFileDescription <=< strDecode
+  strP = strDecode <$?> A.takeByteString
+
+instance FilePartyI p => StrEncoding (FileDescription p) where
+  strEncode = Y.encode . encodeFileDescription
+  strDecode s = strDecode s >>= (\(AFD fd) -> checkParty fd)
+  strP = strDecode <$?> A.takeByteString
+
+instance StrEncoding AFileDescription where
+  strEncode (AFD fd) = strEncode fd
+  strDecode = decodeFileDescription <=< first show . Y.decodeEither'
+  strP = strDecode <$?> A.takeByteString
+
+validateFileDescription :: AFileDescription -> Either String AValidFileDescription
+validateFileDescription = \case
+  AFD 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 $ AVFD (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
+    { party = toFileParty party,
+      size = B.unpack $ strEncode size,
+      digest,
+      key,
+      nonce,
+      chunkSize = B.unpack $ strEncode chunkSize,
+      replicas = encodeFileReplicas chunkSize chunks
+    }
+
+newtype FileSize a = FileSize {unFileSize :: a}
+  deriving (Eq, Show)
+
+instance (Integral a, Show a) => StrEncoding (FileSize a) where
+  strEncode (FileSize b)
+    | b' /= 0 = bshow b
+    | ks' /= 0 = bshow ks <> "kb"
+    | ms' /= 0 = bshow ms <> "mb"
+    | otherwise = bshow gs <> "gb"
+    where
+      (ks, b') = b `divMod` 1024
+      (ms, ks') = ks `divMod` 1024
+      (gs, ms') = ms `divMod` 1024
+  strP =
+    FileSize
+      <$> A.choice
+        [ gb <$> A.decimal <* "gb",
+          mb <$> A.decimal <* "mb",
+          kb <$> A.decimal <* "kb",
+          A.decimal
+        ]
+
+kb :: Integral a => a -> a
+kb n = 1024 * n
+{-# INLINE kb #-}
+
+mb :: Integral a => a -> a
+mb n = 1024 * kb n
+{-# INLINE mb #-}
+
+gb :: Integral a => a -> a
+gb n = 1024 * mb n
+{-# INLINE gb #-}
+
+instance (Integral a, Show a) => IsString (FileSize a) where
+  fromString = either error id . strDecode . B.pack
+
+instance (FromField a) => FromField (FileSize a) where fromField f = FileSize <$> fromField f
+
+instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toField s
+
+groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
+groupReplicasByServer defChunkSize =
+  groupBy ((==) `on` replicaServer)
+    . sortOn replicaServer
+    . unfoldChunksToReplicas defChunkSize
+
+encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas]
+encodeFileReplicas defChunkSize =
+  map encodeServerReplicas . groupReplicasByServer defChunkSize
+  where
+    encodeServerReplicas fs =
+      YAMLServerReplicas
+        { server = replicaServer $ head fs, -- groupBy guarantees that fs is not empty
+          chunks = map (B.unpack . encodeServerReplica) fs
+        }
+
+replicaServer :: FileServerReplica -> XFTPServer
+replicaServer = server
+
+encodeServerReplica :: FileServerReplica -> ByteString
+encodeServerReplica FileServerReplica {chunkNo, replicaId, replicaKey, digest, chunkSize} =
+  bshow chunkNo
+    <> ":"
+    <> strEncode replicaId
+    <> ":"
+    <> strEncode replicaKey
+    <> maybe "" ((":" <>) . strEncode) digest
+    <> maybe "" ((":" <>) . strEncode) chunkSize
+
+serverReplicaP :: XFTPServer -> Parser FileServerReplica
+serverReplicaP server = do
+  chunkNo <- A.decimal
+  replicaId <- A.char ':' *> strP
+  replicaKey <- A.char ':' *> strP
+  digest <- optional (A.char ':' *> strP)
+  chunkSize <- optional (A.char ':' *> strP)
+  pure FileServerReplica {chunkNo, server, replicaId, replicaKey, digest, chunkSize}
+
+unfoldChunksToReplicas :: FileSize Word32 -> [FileChunk] -> [FileServerReplica]
+unfoldChunksToReplicas defChunkSize = concatMap chunkReplicas
+  where
+    chunkReplicas c@FileChunk {replicas} = zipWith (replicaToServerReplica c) [1 ..] replicas
+    replicaToServerReplica :: FileChunk -> Int -> FileChunkReplica -> FileServerReplica
+    replicaToServerReplica FileChunk {chunkNo, digest, chunkSize} replicaNo FileChunkReplica {server, replicaId, replicaKey} =
+      let chunkSize' = if chunkSize /= defChunkSize && replicaNo == 1 then Just chunkSize else Nothing
+          digest' = if replicaNo == 1 then Just digest else Nothing
+       in FileServerReplica {chunkNo, server, replicaId, replicaKey, digest = digest', chunkSize = chunkSize'}
+
+decodeFileDescription :: YAMLFileDescription -> Either String AFileDescription
+decodeFileDescription YAMLFileDescription {party, size, digest, key, nonce, chunkSize, replicas} = do
+  size' <- strDecode $ B.pack size
+  chunkSize' <- strDecode $ B.pack chunkSize
+  replicas' <- decodeFileParts replicas
+  chunks <- foldReplicasToChunks chunkSize' replicas'
+  pure $ case aFileParty party of
+    AFP party' -> AFD FileDescription {party = party', size = size', digest, key, nonce, chunkSize = chunkSize', chunks}
+  where
+    decodeFileParts = fmap concat . mapM decodeYAMLServerReplicas
+
+decodeYAMLServerReplicas :: YAMLServerReplicas -> Either String [FileServerReplica]
+decodeYAMLServerReplicas YAMLServerReplicas {server, chunks} =
+  mapM (parseAll (serverReplicaP server) . B.pack) chunks
+
+-- this function should fail if:
+-- 1. no replica has digest or two replicas have different digests
+-- 2. two replicas have different chunk sizes
+foldReplicasToChunks :: FileSize Word32 -> [FileServerReplica] -> Either String [FileChunk]
+foldReplicasToChunks defChunkSize fs = do
+  sd <- foldSizesDigests fs
+  -- TODO validate (check that chunks match) or in separate function
+  sortOn (chunkNo :: FileChunk -> Int) . map reverseReplicas . M.elems <$> foldChunks sd fs
+  where
+    foldSizesDigests :: [FileServerReplica] -> Either String (Map Int (FileSize Word32), Map Int FileDigest)
+    foldSizesDigests = foldl' addSizeDigest $ Right (M.empty, M.empty)
+    addSizeDigest :: Either String (Map Int (FileSize Word32), Map Int FileDigest) -> FileServerReplica -> Either String (Map Int (FileSize Word32), Map Int FileDigest)
+    addSizeDigest (Left e) _ = Left e
+    addSizeDigest (Right (ms, md)) FileServerReplica {chunkNo, chunkSize, digest} =
+      (,) <$> combineChunk ms chunkNo chunkSize <*> combineChunk md chunkNo digest
+    combineChunk :: Eq a => Map Int a -> Int -> Maybe a -> Either String (Map Int a)
+    combineChunk m _ Nothing = Right m
+    combineChunk m chunkNo (Just value) = case M.lookup chunkNo m of
+      Nothing -> Right $ M.insert chunkNo value m
+      Just v -> if v == value then Right m else Left "different size or digest in chunk replicas"
+    foldChunks :: (Map Int (FileSize Word32), Map Int FileDigest) -> [FileServerReplica] -> Either String (Map Int FileChunk)
+    foldChunks sd = foldl' (addReplica sd) (Right M.empty)
+    addReplica :: (Map Int (FileSize Word32), Map Int FileDigest) -> Either String (Map Int FileChunk) -> FileServerReplica -> Either String (Map Int FileChunk)
+    addReplica _ (Left e) _ = Left e
+    addReplica (ms, md) (Right cs) FileServerReplica {chunkNo, server, replicaId, replicaKey} = do
+      case M.lookup chunkNo cs of
+        Just chunk@FileChunk {replicas} ->
+          let replica = FileChunkReplica {server, replicaId, replicaKey}
+           in Right $ M.insert chunkNo ((chunk :: FileChunk) {replicas = replica : replicas}) cs
+        _ -> do
+          case M.lookup chunkNo md of
+            Just digest' ->
+              let replica = FileChunkReplica {server, replicaId, replicaKey}
+                  chunkSize' = fromMaybe defChunkSize $ M.lookup chunkNo ms
+                  chunk = FileChunk {chunkNo, digest = digest', chunkSize = chunkSize', replicas = [replica]}
+               in Right $ M.insert chunkNo chunk cs
+            _ -> Left "no digest for chunk"
+    reverseReplicas c@FileChunk {replicas} = (c :: FileChunk) {replicas = reverse replicas}

src/Simplex/FileTransfer/Protocol.hs

@@ -0,0 +1,434 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
+module Simplex.FileTransfer.Protocol where
+
+import Control.Applicative ((<|>))
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Kind (Type)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe (isNothing)
+import Data.Type.Equality
+import Data.Word (Word32)
+import GHC.Generics (Generic)
+import Generic.Random (genericArbitraryU)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
+import Simplex.Messaging.Parsers
+import Simplex.Messaging.Protocol
+  ( BasicAuth,
+    CommandError (..),
+    Protocol (..),
+    ProtocolEncoding (..),
+    ProtocolErrorType (..),
+    ProtocolMsgTag (..),
+    ProtocolType (..),
+    RcvPublicDhKey,
+    RcvPublicVerifyKey,
+    RecipientId,
+    SenderId,
+    SentRawTransmission,
+    SignedTransmission,
+    SndPublicVerifyKey,
+    Transmission,
+    encodeTransmission,
+    messageTagP,
+    tDecodeParseValidate,
+    tEncode,
+    tEncodeBatch,
+    tParse,
+    _smpP,
+  )
+import Simplex.Messaging.Transport (SessionId, TransportError (..))
+import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.Version
+import Test.QuickCheck (Arbitrary (..))
+
+currentXFTPVersion :: Version
+currentXFTPVersion = 1
+
+xftpBlockSize :: Int
+xftpBlockSize = 16384
+
+-- | File protocol clients
+data FileParty = FRecipient | FSender
+  deriving (Eq, Show, Generic)
+
+instance FromJSON FileParty where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "F"
+
+instance ToJSON FileParty where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "F"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "F"
+
+data SFileParty :: FileParty -> Type where
+  SFRecipient :: SFileParty FRecipient
+  SFSender :: SFileParty FSender
+
+instance TestEquality SFileParty where
+  testEquality SFRecipient SFRecipient = Just Refl
+  testEquality SFSender SFSender = Just Refl
+  testEquality _ _ = Nothing
+
+deriving instance Eq (SFileParty p)
+
+deriving instance Show (SFileParty p)
+
+data AFileParty = forall p. FilePartyI p => AFP (SFileParty p)
+
+toFileParty :: SFileParty p -> FileParty
+toFileParty = \case
+  SFRecipient -> FRecipient
+  SFSender -> FSender
+
+aFileParty :: FileParty -> AFileParty
+aFileParty = \case
+  FRecipient -> AFP SFRecipient
+  FSender -> AFP SFSender
+
+class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p
+
+instance FilePartyI FRecipient where sFileParty = SFRecipient
+
+instance FilePartyI FSender where sFileParty = SFSender
+
+data FileCommandTag (p :: FileParty) where
+  FNEW_ :: FileCommandTag FSender
+  FADD_ :: FileCommandTag FSender
+  FPUT_ :: FileCommandTag FSender
+  FDEL_ :: FileCommandTag FSender
+  FGET_ :: FileCommandTag FRecipient
+  FACK_ :: FileCommandTag FRecipient
+  PING_ :: FileCommandTag FRecipient
+
+deriving instance Show (FileCommandTag p)
+
+data FileCmdTag = forall p. FilePartyI p => FCT (SFileParty p) (FileCommandTag p)
+
+instance FilePartyI p => Encoding (FileCommandTag p) where
+  smpEncode = \case
+    FNEW_ -> "FNEW"
+    FADD_ -> "FADD"
+    FPUT_ -> "FPUT"
+    FDEL_ -> "FDEL"
+    FGET_ -> "FGET"
+    FACK_ -> "FACK"
+    PING_ -> "PING"
+  smpP = messageTagP
+
+instance Encoding FileCmdTag where
+  smpEncode (FCT _ t) = smpEncode t
+  smpP = messageTagP
+
+instance ProtocolMsgTag FileCmdTag where
+  decodeTag = \case
+    "FNEW" -> Just $ FCT SFSender FNEW_
+    "FADD" -> Just $ FCT SFSender FADD_
+    "FPUT" -> Just $ FCT SFSender FPUT_
+    "FDEL" -> Just $ FCT SFSender FDEL_
+    "FGET" -> Just $ FCT SFRecipient FGET_
+    "FACK" -> Just $ FCT SFRecipient FACK_
+    "PING" -> Just $ FCT SFRecipient PING_
+    _ -> Nothing
+
+instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
+  decodeTag s = decodeTag s >>= (\(FCT _ t) -> checkParty' t)
+
+instance Protocol XFTPErrorType FileResponse where
+  type ProtoCommand FileResponse = FileCmd
+  type ProtoType FileResponse = 'PXFTP
+  protocolClientHandshake = ntfClientHandshake
+  protocolPing = FileCmd SFRecipient PING
+  protocolError = \case
+    FRErr e -> Just e
+    _ -> Nothing
+
+data FileCommand (p :: FileParty) where
+  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FSender
+  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FSender
+  FPUT :: FileCommand FSender
+  FDEL :: FileCommand FSender
+  FGET :: RcvPublicDhKey -> FileCommand FRecipient
+  FACK :: FileCommand FRecipient
+  PING :: FileCommand FRecipient
+
+deriving instance Show (FileCommand p)
+
+data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p)
+
+deriving instance Show FileCmd
+
+data FileInfo = FileInfo
+  { sndKey :: SndPublicVerifyKey,
+    size :: Word32,
+    digest :: ByteString
+  }
+  deriving (Eq, Show)
+
+type XFTPFileId = ByteString
+
+instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
+  type Tag (FileCommand p) = FileCommandTag p
+  encodeProtocol _v = \case
+    FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
+    FADD rKeys -> e (FADD_, ' ', rKeys)
+    FPUT -> e FPUT_
+    FDEL -> e FDEL_
+    FGET rKey -> e (FGET_, ' ', rKey)
+    FACK -> e FACK_
+    PING -> e PING_
+    where
+      e :: Encoding a => a -> ByteString
+      e = smpEncode
+
+  protocolP v tag = (\(FileCmd _ c) -> checkParty c) <$?> protocolP v (FCT (sFileParty @p) tag)
+
+  fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse
+  {-# INLINE fromProtocolError #-}
+
+  checkCredentials (sig, _, fileId, _) cmd = case cmd of
+    -- FNEW must not have signature and chunk ID
+    FNEW {}
+      | isNothing sig -> Left $ CMD NO_AUTH
+      | not (B.null fileId) -> Left $ CMD HAS_AUTH
+      | otherwise -> Right cmd
+    PING
+      | isNothing sig && B.null fileId -> Right cmd
+      | otherwise -> Left $ CMD HAS_AUTH
+    -- other client commands must have both signature and queue ID
+    _
+      | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH
+      | otherwise -> Right cmd
+
+instance ProtocolEncoding XFTPErrorType FileCmd where
+  type Tag FileCmd = FileCmdTag
+  encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
+
+  protocolP _v = \case
+    FCT SFSender tag ->
+      FileCmd SFSender <$> case tag of
+        FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
+        FADD_ -> FADD <$> _smpP
+        FPUT_ -> pure FPUT
+        FDEL_ -> pure FDEL
+    FCT SFRecipient tag ->
+      FileCmd SFRecipient <$> case tag of
+        FGET_ -> FGET <$> _smpP
+        FACK_ -> pure FACK
+        PING_ -> pure PING
+
+  fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse
+  {-# INLINE fromProtocolError #-}
+
+  checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
+
+instance Encoding FileInfo where
+  smpEncode FileInfo {sndKey, size, digest} = smpEncode (sndKey, size, digest)
+  smpP = FileInfo <$> smpP <*> smpP <*> smpP
+
+instance StrEncoding FileInfo where
+  strEncode FileInfo {sndKey, size, digest} = strEncode (sndKey, size, digest)
+  strP = FileInfo <$> strP_ <*> strP_ <*> strP
+
+data FileResponseTag
+  = FRSndIds_
+  | FRRcvIds_
+  | FRFile_
+  | FROk_
+  | FRErr_
+  | FRPong_
+  deriving (Show)
+
+instance Encoding FileResponseTag where
+  smpEncode = \case
+    FRSndIds_ -> "SIDS"
+    FRRcvIds_ -> "RIDS"
+    FRFile_ -> "FILE"
+    FROk_ -> "OK"
+    FRErr_ -> "ERR"
+    FRPong_ -> "PONG"
+  smpP = messageTagP
+
+instance ProtocolMsgTag FileResponseTag where
+  decodeTag = \case
+    "SIDS" -> Just FRSndIds_
+    "RIDS" -> Just FRRcvIds_
+    "FILE" -> Just FRFile_
+    "OK" -> Just FROk_
+    "ERR" -> Just FRErr_
+    "PONG" -> Just FRPong_
+    _ -> Nothing
+
+data FileResponse
+  = FRSndIds SenderId (NonEmpty RecipientId)
+  | FRRcvIds (NonEmpty RecipientId)
+  | FRFile RcvPublicDhKey C.CbNonce
+  | FROk
+  | FRErr XFTPErrorType
+  | FRPong
+  deriving (Show)
+
+instance ProtocolEncoding XFTPErrorType FileResponse where
+  type Tag FileResponse = FileResponseTag
+  encodeProtocol _v = \case
+    FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
+    FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
+    FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
+    FROk -> e FROk_
+    FRErr err -> e (FRErr_, ' ', err)
+    FRPong -> e FRPong_
+    where
+      e :: Encoding a => a -> ByteString
+      e = smpEncode
+
+  protocolP _v = \case
+    FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
+    FRRcvIds_ -> FRRcvIds <$> _smpP
+    FRFile_ -> FRFile <$> _smpP <*> smpP
+    FROk_ -> pure FROk
+    FRErr_ -> FRErr <$> _smpP
+    FRPong_ -> pure FRPong
+
+  fromProtocolError = \case
+    PECmdSyntax -> CMD SYNTAX
+    PECmdUnknown -> CMD UNKNOWN
+    PESession -> SESSION
+    PEBlock -> BLOCK
+  {-# INLINE fromProtocolError #-}
+
+  checkCredentials (_, _, entId, _) cmd = case cmd of
+    FRSndIds {} -> noEntity
+    -- ERR response does not always have entity ID
+    FRErr _ -> Right cmd
+    -- PONG response must not have queue ID
+    FRPong -> noEntity
+    -- other server responses must have entity ID
+    _
+      | B.null entId -> Left $ CMD NO_ENTITY
+      | otherwise -> Right cmd
+    where
+      noEntity
+        | B.null entId = Right cmd
+        | otherwise = Left $ CMD HAS_AUTH
+
+data XFTPErrorType
+  = -- | incorrect block format, encoding or signature size
+    BLOCK
+  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
+    SESSION
+  | -- | SMP command is unknown or has invalid syntax
+    CMD {cmdErr :: CommandError}
+  | -- | command authorization error - bad signature or non-existing SMP queue
+    AUTH
+  | -- | incorrent file size
+    SIZE
+  | -- | storage quota exceeded
+    QUOTA
+  | -- | incorrent file digest
+    DIGEST
+  | -- | file encryption/decryption failed
+    CRYPTO
+  | -- | no expected file body in request/response or no file on the server
+    NO_FILE
+  | -- | unexpected file body
+    HAS_FILE
+  | -- | file IO error
+    FILE_IO
+  | -- | internal server error
+    INTERNAL
+  | -- | used internally, never returned by the server (to be removed)
+    DUPLICATE_ -- not part of SMP protocol, used internally
+  deriving (Eq, Generic, Read, Show)
+
+instance ToJSON XFTPErrorType where
+  toJSON = J.genericToJSON $ sumTypeJSON id
+  toEncoding = J.genericToEncoding $ sumTypeJSON id
+
+instance StrEncoding XFTPErrorType where
+  strEncode = \case
+    CMD e -> "CMD " <> bshow e
+    e -> bshow e
+  strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
+
+instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU
+
+instance Encoding XFTPErrorType where
+  smpEncode = \case
+    BLOCK -> "BLOCK"
+    SESSION -> "SESSION"
+    CMD err -> "CMD " <> smpEncode err
+    AUTH -> "AUTH"
+    SIZE -> "SIZE"
+    QUOTA -> "QUOTA"
+    DIGEST -> "DIGEST"
+    CRYPTO -> "CRYPTO"
+    NO_FILE -> "NO_FILE"
+    HAS_FILE -> "HAS_FILE"
+    FILE_IO -> "FILE_IO"
+    INTERNAL -> "INTERNAL"
+    DUPLICATE_ -> "DUPLICATE_"
+
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "BLOCK" -> pure BLOCK
+      "SESSION" -> pure SESSION
+      "CMD" -> CMD <$> _smpP
+      "AUTH" -> pure AUTH
+      "SIZE" -> pure SIZE
+      "QUOTA" -> pure QUOTA
+      "DIGEST" -> pure DIGEST
+      "CRYPTO" -> pure CRYPTO
+      "NO_FILE" -> pure NO_FILE
+      "HAS_FILE" -> pure HAS_FILE
+      "FILE_IO" -> pure FILE_IO
+      "INTERNAL" -> pure INTERNAL
+      "DUPLICATE_" -> pure DUPLICATE_
+      _ -> fail "bad error type"
+
+checkParty :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Either String (t p)
+checkParty c = case testEquality (sFileParty @p) (sFileParty @p') of
+  Just Refl -> Right c
+  Nothing -> Left "incorrect XFTP party"
+
+checkParty' :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Maybe (t p)
+checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
+  Just Refl -> Just c
+  _ -> Nothing
+
+xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString
+xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do
+  let t = encodeTransmission currentXFTPVersion sessionId (corrId, fId, msg)
+  xftpEncodeBatch1 $ signTransmission t
+  where
+    signTransmission :: ByteString -> SentRawTransmission
+    signTransmission t = ((`C.sign` t) <$> pKey, t)
+
+-- this function uses batch syntax but puts only one transmission in the batch
+xftpEncodeBatch1 :: (Maybe C.ASignature, ByteString) -> Either TransportError ByteString
+xftpEncodeBatch1 (sig, t) =
+  let t' = tEncodeBatch 1 . smpEncode . Large $ tEncode (sig, t)
+   in first (const TELargeMsg) $ C.pad t' xftpBlockSize
+
+xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
+xftpDecodeTransmission sessionId t = do
+  t' <- first (const BLOCK) $ C.unPad t
+  case tParse True t' of
+    t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t''
+    _ -> Left BLOCK

src/Simplex/FileTransfer/Server.hs

@@ -0,0 +1,397 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Server where
+
+import Control.Logger.Simple
+import Control.Monad.Except
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Reader
+import Crypto.Random (getRandomBytes)
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Base64.URL as B64
+import Data.ByteString.Builder (byteString)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
+import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.Word (Word32)
+import qualified Network.HTTP.Types as N
+import qualified Network.HTTP2.Server as H
+import Simplex.FileTransfer.Protocol
+import Simplex.FileTransfer.Server.Env
+import Simplex.FileTransfer.Server.Stats
+import Simplex.FileTransfer.Server.Store
+import Simplex.FileTransfer.Server.StoreLog
+import Simplex.FileTransfer.Transport
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId)
+import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
+import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Transport.HTTP2
+import Simplex.Messaging.Transport.HTTP2.Server
+import Simplex.Messaging.Util
+import System.Exit (exitFailure)
+import System.FilePath ((</>))
+import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
+import UnliftIO (IOMode (..), withFile)
+import UnliftIO.Concurrent (threadDelay)
+import UnliftIO.Directory (doesFileExist, removeFile, renameFile)
+import UnliftIO.Exception
+import UnliftIO.STM
+
+type M a = ReaderT XFTPEnv IO a
+
+runXFTPServer :: XFTPServerConfig -> IO ()
+runXFTPServer cfg = do
+  started <- newEmptyTMVarIO
+  runXFTPServerBlocking started cfg
+
+runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
+runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
+
+xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
+xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
+  restoreServerStats
+  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer
+  where
+    runServer :: M ()
+    runServer = do
+      serverParams <- asks tlsServerParams
+      env <- ask
+      liftIO $
+        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams logTLSErrors $ \sessionId r sendResponse -> do
+          reqBody <- getHTTP2Body r xftpBlockSize
+          processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
+
+    stopServer :: M ()
+    stopServer = do
+      withFileLog closeStoreLog
+      saveServerStats
+
+    expireFilesThread_ :: XFTPServerConfig -> [M ()]
+    expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
+    expireFilesThread_ _ = []
+
+    expireFiles :: ExpirationConfig -> M ()
+    expireFiles expCfg = do
+      st <- asks store
+      let interval = checkInterval expCfg * 1000000
+      forever $ do
+        threadDelay interval
+        old <- liftIO $ expireBeforeEpoch expCfg
+        sIds <- M.keysSet <$> readTVarIO (files st)
+        forM_ sIds $ \sId -> do
+          threadDelay 100000
+          atomically (expiredFilePath st sId old)
+            >>= mapM_ (remove $ delete st sId)
+      where
+        remove del filePath =
+          ifM
+            (doesFileExist filePath)
+            (removeFile filePath >> del `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
+            del
+        delete st sId = do
+          withFileLog (`logDeleteFile` sId)
+          void $ atomically $ deleteFile st sId
+
+    serverStatsThread_ :: XFTPServerConfig -> [M ()]
+    serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
+      [logServerStats logStatsStartTime interval serverStatsLogFile]
+    serverStatsThread_ _ = []
+
+    logServerStats :: Int -> Int -> FilePath -> M ()
+    logServerStats startAt logInterval statsFilePath = do
+      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
+      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
+      threadDelay $ 1_000_000 * (initialDelay + if initialDelay < 0 then 86_400 else 0)
+      FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} <- asks serverStats
+      let interval = 1_000_000 * logInterval
+      forever $ do
+        withFile statsFilePath AppendMode $ \h -> liftIO $ do
+          hSetBuffering h LineBuffering
+          ts <- getCurrentTime
+          fromTime' <- atomically $ swapTVar fromTime ts
+          filesCreated' <- atomically $ swapTVar filesCreated 0
+          fileRecipients' <- atomically $ swapTVar fileRecipients 0
+          filesUploaded' <- atomically $ swapTVar filesUploaded 0
+          filesDeleted' <- atomically $ swapTVar filesDeleted 0
+          files <- atomically $ periodStatCounts filesDownloaded ts
+          fileDownloads' <- atomically $ swapTVar fileDownloads 0
+          fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0
+          filesCount' <- atomically $ swapTVar filesCount 0
+          filesSize' <- atomically $ swapTVar filesSize 0
+          hPutStrLn h $
+            intercalate
+              ","
+              [ iso8601Show $ utctDay fromTime',
+                show filesCreated',
+                show fileRecipients',
+                show filesUploaded',
+                show filesDeleted',
+                dayCount files,
+                weekCount files,
+                monthCount files,
+                show fileDownloads',
+                show fileDownloadAcks',
+                show filesCount',
+                show filesSize'
+              ]
+        threadDelay interval
+
+data ServerFile = ServerFile
+  { filePath :: FilePath,
+    fileSize :: Word32,
+    sbState :: LC.SbState
+  }
+
+processRequest :: HTTP2Request -> M ()
+processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
+  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
+  | otherwise = do
+    case xftpDecodeTransmission sessionId bodyHead of
+      Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
+        case cmdOrErr of
+          Right cmd -> do
+            verifyXFTPTransmission sig_ signed fId cmd >>= \case
+              VRVerified req -> uncurry send =<< processXFTPRequest body req
+              VRFailed -> send (FRErr AUTH) Nothing
+          Left e -> send (FRErr e) Nothing
+        where
+          send resp = sendXFTPResponse (corrId, fId, resp)
+      Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
+  where
+    sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
+    sendXFTPResponse (corrId, fId, resp) serverFile_ = do
+      let t_ = xftpEncodeTransmission sessionId Nothing (corrId, fId, resp)
+      liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
+      where
+        streamBody t_ send done = do
+          case t_ of
+            Left _ -> do
+              send "padding error" -- TODO respond with BLOCK error?
+              done
+            Right t -> do
+              send $ byteString t
+              -- timeout sending file in the same way as receiving
+              forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do
+                withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize)
+          done
+
+data VerificationResult = VRVerified XFTPRequest | VRFailed
+
+verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
+verifyXFTPTransmission sig_ signed fId cmd =
+  case cmd of
+    FileCmd SFSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
+    FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
+    FileCmd party _ -> verifyCmd party
+  where
+    verifyCmd :: SFileParty p -> M VerificationResult
+    verifyCmd party = do
+      st <- asks store
+      atomically $ verify <$> getFile st party fId
+      where
+        verify = \case
+          Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k
+          _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+    req `verifyWith` k = if verifyCmdSignature sig_ signed k then VRVerified req else VRFailed
+
+processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
+processXFTPRequest HTTP2Body {bodyPart} = \case
+  XFTPReqNew file rks auth -> do
+    st <- asks store
+    noFile
+      =<< ifM
+        allowNew
+        (createFile st file rks)
+        (pure $ FRErr AUTH)
+    where
+      allowNew = do
+        XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
+        pure $ allowNewFiles && maybe True ((== auth) . Just) newFileBasicAuth
+  XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
+    FADD _rcps -> noFile FROk
+    FPUT -> noFile =<< receiveServerFile fr
+    FDEL -> noFile =<< deleteServerFile fr
+    FGET rDhKey -> sendServerFile fr rDhKey
+    FACK -> noFile =<< ackFileReception fId fr
+    -- it should never get to the commands below, they are passed in other constructors of XFTPRequest
+    FNEW {} -> noFile $ FRErr INTERNAL
+    PING -> noFile FRPong
+  XFTPReqPing -> noFile FRPong
+  where
+    noFile resp = pure (resp, Nothing)
+    createFile :: FileStore -> FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    createFile st file rks = do
+      r <- runExceptT $ do
+        sizes <- asks $ allowedChunkSizes . config
+        unless (size file `elem` sizes) $ throwError SIZE
+        ts <- liftIO getSystemTime
+        -- TODO validate body empty
+        sId <- ExceptT $ addFileRetry 3 ts
+        rcps <- mapM (ExceptT . addRecipientRetry 3 sId) rks
+        withFileLog $ \sl -> do
+          logAddFile sl sId file ts
+          logAddRecipients sl sId rcps
+        stats <- asks serverStats
+        atomically $ modifyTVar' (filesCreated stats) (+ 1)
+        atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
+        let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
+        pure $ FRSndIds sId rIds
+      pure $ either FRErr id r
+      where
+        addFileRetry :: Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
+        addFileRetry n ts =
+          retryAdd n $ \sId -> runExceptT $ do
+            ExceptT $ addFile st sId file ts
+            pure sId
+        addRecipientRetry :: Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient)
+        addRecipientRetry n sId rpk =
+          retryAdd n $ \rId -> runExceptT $ do
+            let rcp = FileRecipient rId rpk
+            ExceptT $ addRecipient st sId rcp
+            pure rcp
+        retryAdd :: Int -> (XFTPFileId -> STM (Either XFTPErrorType a)) -> M (Either XFTPErrorType a)
+        retryAdd 0 _ = pure $ Left INTERNAL
+        retryAdd n add = do
+          fId <- getFileId
+          atomically (add fId) >>= \case
+            Left DUPLICATE_ -> retryAdd (n - 1) add
+            r -> pure r
+    receiveServerFile :: FileRec -> M FileResponse
+    receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
+      -- TODO do not allow repeated file upload
+      Nothing -> pure $ FRErr SIZE
+      Just getBody -> do
+        -- TODO validate body size before downloading, once it's populated
+        path <- asks $ filesPath . config
+        let fPath = path </> B.unpack (B64.encode senderId)
+            FileInfo {size, digest} = fileInfo
+        withFileLog $ \sl -> logPutFile sl senderId fPath
+        st <- asks store
+        quota_ <- asks $ fileSizeQuota . config
+        -- TODO timeout file upload, remove partially uploaded files
+        stats <- asks serverStats
+        liftIO $
+          runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
+            Right () -> do
+              used <- readTVarIO $ usedStorage st
+              if maybe False (used + fromIntegral size >) quota_
+                then remove fPath $> FRErr QUOTA
+                else do
+                  atomically (setFilePath' st fr fPath)
+                  atomically $ modifyTVar' (filesUploaded stats) (+ 1)
+                  atomically $ modifyTVar' (filesCount stats) (+ 1)
+                  atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size)
+                  pure FROk
+            Left e -> remove fPath $> FRErr e
+        where
+          remove fPath = whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError
+
+    sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
+    sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
+      readTVarIO filePath >>= \case
+        Just path -> do
+          (sDhKey, spDhKey) <- liftIO C.generateKeyPair'
+          let dhSecret = C.dh' rDhKey spDhKey
+          cbNonce <- liftIO C.randomCbNonce
+          case LC.cbInit dhSecret cbNonce of
+            Right sbState -> do
+              stats <- asks serverStats
+              atomically $ modifyTVar' (fileDownloads stats) (+ 1)
+              atomically $ updatePeriodStats (filesDownloaded stats) senderId
+              pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
+            _ -> pure (FRErr INTERNAL, Nothing)
+        _ -> pure (FRErr NO_FILE, Nothing)
+
+    deleteServerFile :: FileRec -> M FileResponse
+    deleteServerFile FileRec {senderId, fileInfo, filePath} = do
+      withFileLog (`logDeleteFile` senderId)
+      r <- runExceptT $ do
+        path <- readTVarIO filePath
+        stats <- asks serverStats
+        ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
+        st <- asks store
+        void $ atomically $ deleteFile st senderId
+        atomically $ modifyTVar' (filesDeleted stats) (+ 1)
+        pure FROk
+      either (pure . FRErr) pure r
+      where
+        deletedStats stats = do
+          atomically $ modifyTVar' (filesCount stats) (subtract 1)
+          atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
+
+    logFileError :: SomeException -> IO ()
+    logFileError e = logError $ "Error deleting file: " <> tshow e
+
+    ackFileReception :: RecipientId -> FileRec -> M FileResponse
+    ackFileReception rId fr = do
+      withFileLog (`logAckFile` rId)
+      st <- asks store
+      atomically $ deleteRecipient st rId fr
+      stats <- asks serverStats
+      atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1)
+      pure FROk
+
+randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
+randomId n = do
+  gVar <- asks idsDrg
+  atomically (C.pseudoRandomBytes n gVar)
+
+getFileId :: M XFTPFileId
+getFileId = liftIO . getRandomBytes =<< asks (fileIdSize . config)
+
+withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
+withFileLog action = liftIO . mapM_ action =<< asks storeLog
+
+incFileStat :: (FileServerStats -> TVar Int) -> M ()
+incFileStat statSel = do
+  stats <- asks serverStats
+  atomically $ modifyTVar (statSel stats) (+ 1)
+
+saveServerStats :: M ()
+saveServerStats =
+  asks (serverStatsBackupFile . config)
+    >>= mapM_ (\f -> asks serverStats >>= atomically . getFileServerStatsData >>= liftIO . saveStats f)
+  where
+    saveStats f stats = do
+      logInfo $ "saving server stats to file " <> T.pack f
+      B.writeFile f $ strEncode stats
+      logInfo "server stats saved"
+
+restoreServerStats :: M ()
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
+  where
+    restoreStats f = whenM (doesFileExist f) $ do
+      logInfo $ "restoring server stats from file " <> T.pack f
+      liftIO (strDecode <$> B.readFile f) >>= \case
+        Right d -> do
+          s <- asks serverStats
+          fs <- readTVarIO . files =<< asks store
+          let _filesCount = length $ M.keys fs
+              _filesSize = M.foldl' (\n -> (n +) . fromIntegral . size . fileInfo) 0 fs
+          atomically $ setFileServerStats s d {_filesCount, _filesSize}
+          renameFile f $ f <> ".bak"
+          logInfo "server stats restored"
+        Left e -> do
+          logInfo $ "error restoring server stats: " <> T.pack e
+          liftIO exitFailure

src/Simplex/FileTransfer/Server/Env.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+
+module Simplex.FileTransfer.Server.Env where
+
+import Control.Logger.Simple (logInfo)
+import Control.Monad
+import Control.Monad.IO.Unlift
+import Crypto.Random
+import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Time.Clock (getCurrentTime)
+import Data.Word (Word32)
+import Data.X509.Validation (Fingerprint (..))
+import Network.Socket
+import qualified Network.TLS as T
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo, XFTPFileId)
+import Simplex.FileTransfer.Server.Stats
+import Simplex.FileTransfer.Server.Store
+import Simplex.FileTransfer.Server.StoreLog
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey)
+import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Util (tshow)
+import System.IO (IOMode (..))
+import UnliftIO.STM
+
+data XFTPServerConfig = XFTPServerConfig
+  { xftpPort :: ServiceName,
+    fileIdSize :: Int,
+    storeLogFile :: Maybe FilePath,
+    filesPath :: FilePath,
+    -- | server storage quota
+    fileSizeQuota :: Maybe Int64,
+    -- | allowed file chunk sizes
+    allowedChunkSizes :: [Word32],
+    -- | set to False to prohibit creating new files
+    allowNewFiles :: Bool,
+    -- | simple password that the clients need to pass in handshake to be able to create new files
+    newFileBasicAuth :: Maybe BasicAuth,
+    -- | time after which the files can be removed and check interval, seconds
+    fileExpiration :: Maybe ExpirationConfig,
+    -- CA certificate private key is not needed for initialization
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    certificateFile :: FilePath,
+    -- stats config - see SMP server config
+    logStatsInterval :: Maybe Int,
+    logStatsStartTime :: Int,
+    serverStatsLogFile :: FilePath,
+    serverStatsBackupFile :: Maybe FilePath,
+    logTLSErrors :: Bool
+  }
+
+data XFTPEnv = XFTPEnv
+  { config :: XFTPServerConfig,
+    store :: FileStore,
+    storeLog :: Maybe (StoreLog 'WriteMode),
+    idsDrg :: TVar ChaChaDRG,
+    serverIdentity :: C.KeyHash,
+    tlsServerParams :: T.ServerParams,
+    serverStats :: FileServerStats
+  }
+
+defaultFileExpiration :: ExpirationConfig
+defaultFileExpiration =
+  ExpirationConfig
+    { ttl = 48 * 3600, -- seconds, 48 hours
+      checkInterval = 2 * 3600 -- seconds, 2 hours
+    }
+
+newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv
+newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
+  idsDrg <- drgNew >>= newTVarIO
+  store <- atomically newFileStore
+  storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
+  used <- readTVarIO (usedStorage store)
+  forM_ fileSizeQuota $ \quota -> do
+    logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
+    when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
+  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
+  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
+  serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
+  pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+
+data XFTPRequest
+  = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth)
+  | XFTPReqCmd XFTPFileId FileRec FileCmd
+  | XFTPReqPing

src/Simplex/FileTransfer/Server/Main.hs

@@ -0,0 +1,214 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Simplex.FileTransfer.Server.Main where
+
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Ini (lookupValue, readIniFile)
+import Data.Int (Int64)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Network.Socket (HostName)
+import Options.Applicative
+import Simplex.FileTransfer.Description (FileSize (..), kb, mb)
+import Simplex.FileTransfer.Server (runXFTPServer)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
+import Simplex.Messaging.Server.CLI
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.FilePath (combine)
+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
+import Text.Read (readMaybe)
+
+xftpServerVersion :: String
+xftpServerVersion = "0.1.0"
+
+xftpServerCLI :: FilePath -> FilePath -> IO ()
+xftpServerCLI cfgPath logPath = do
+  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
+    Init opts ->
+      doesFileExist iniFile >>= \case
+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
+        _ -> initializeServer opts
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError runServer
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    Delete -> do
+      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+      deleteDirIfExists cfgPath
+      deleteDirIfExists logPath
+      putStrLn "Deleted configuration and log files"
+  where
+    iniFile = combine cfgPath "file-server.ini"
+    serverVersion = "SimpleX XFTP server v" <> xftpServerVersion
+    defaultServerPort = "443"
+    executableName = "file-server"
+    storeLogFilePath = combine logPath "file-server-store.log"
+    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota} = do
+      clearDirIfExists cfgPath
+      clearDirIfExists logPath
+      createDirectoryIfMissing True cfgPath
+      createDirectoryIfMissing True logPath
+      let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
+      fp <- createServerX509 cfgPath x509cfg
+      let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
+          srv = ProtoServerWithAuth (XFTPServer [THDomainName host] "" (C.KeyHash fp)) Nothing
+      writeFile iniFile $ iniFileContent host
+      putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
+      warnCAPrivateKeyFile cfgPath x509cfg
+      printServiceInfo serverVersion srv
+      where
+        iniFileContent host =
+          "[STORE_LOG]\n\
+          \# The server uses STM memory for persistence,\n\
+          \# that will be lost on restart (e.g., as with redis).\n\
+          \# This option enables saving memory to append only log,\n\
+          \# and restoring it when the server is started.\n\
+          \# Log is compacted on start (deleted objects are removed).\n"
+            <> ("enable: " <> onOff enableStoreLog <> "\n\n")
+            <> "log_stats: off\n\
+               \\n\
+               \[AUTH]\n\
+               \# Set new_files option to off to completely prohibit uploading new files.\n\
+               \# This can be useful when you want to decommission the server, but still allow downloading the existing files.\n\
+               \new_files: on\n\
+               \\n\
+               \# Use create_password option to enable basic auth to upload new files.\n\
+               \# The password should be used as part of server address in client configuration:\n\
+               \# xftp://fingerprint:password@host1,host2\n\
+               \# The password will not be shared with file recipients, you must share it only\n\
+               \# with the users who you want to allow uploading files to your server.\n\
+               \# create_password: password to upload files (any printable ASCII characters without whitespace, '@', ':' and '/')\n\
+               \\n\
+               \[TRANSPORT]\n\
+               \# host is only used to print server address on start\n"
+            <> ("host: " <> host <> "\n")
+            <> ("port: " <> defaultServerPort <> "\n")
+            <> "log_tls_errors: off\n\
+               \\n\
+               \[FILES]\n"
+            <> ("path: " <> filesPath <> "\n")
+            <> ("storage_quota: " <> B.unpack (strEncode fileSizeQuota) <> "\n")
+    runServer ini = do
+      hSetBuffering stdout LineBuffering
+      hSetBuffering stderr LineBuffering
+      fp <- checkSavedFingerprint cfgPath defaultX509Config
+      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
+          port = T.unpack $ strictIni "TRANSPORT" "port" ini
+          srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
+      printServiceInfo serverVersion srv
+      printXFTPConfig serverConfig
+      runXFTPServer serverConfig
+      where
+        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+        logStats = settingIsOn "STORE_LOG" "log_stats" ini
+        c = combine cfgPath . ($ defaultX509Config)
+        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile} = do
+          putStrLn $ case storeLogFile of
+            Just f -> "Store log: " <> f
+            _ -> "Store log disabled."
+          putStrLn $
+            "Uploading new files "
+              <> if allowNewFiles
+                then maybe "allowed." (const "requires password.") newFileBasicAuth
+                else "NOT allowed."
+          putStrLn $ "Listening on port " <> xftpPort <> "..."
+
+        serverConfig =
+          XFTPServerConfig
+            { xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini,
+              fileIdSize = 16,
+              storeLogFile = enableStoreLog $> storeLogFilePath,
+              filesPath = T.unpack $ strictIni "FILES" "path" ini,
+              fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini,
+              allowedChunkSizes = [kb 256, mb 1, mb 4],
+              allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
+              newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
+              fileExpiration = Just defaultFileExpiration,
+              caCertificateFile = c caCrtFile,
+              privateKeyFile = c serverKeyFile,
+              certificateFile = c serverCrtFile,
+              logStatsInterval = logStats $> 86400, -- seconds
+              logStatsStartTime = 0, -- seconds from 00:00 UTC
+              serverStatsLogFile = combine logPath "file-server-stats.daily.log",
+              serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
+              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+            }
+
+data CliCommand
+  = Init InitOptions
+  | Start
+  | Delete
+
+data InitOptions = InitOptions
+  { enableStoreLog :: Bool,
+    signAlgorithm :: SignAlgorithm,
+    ip :: HostName,
+    fqdn :: Maybe HostName,
+    filesPath :: FilePath,
+    fileSizeQuota :: FileSize Int64
+  }
+  deriving (Show)
+
+cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
+cliCommandP cfgPath logPath iniFile =
+  hsubparser
+    ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
+        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
+        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+    )
+  where
+    initP :: Parser InitOptions
+    initP =
+      InitOptions
+        <$> switch
+          ( long "store-log"
+              <> short 'l'
+              <> help "Enable store log for persistence"
+          )
+        <*> option
+          (maybeReader readMaybe)
+          ( long "sign-algorithm"
+              <> short 'a'
+              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
+              <> value ED448
+              <> showDefault
+              <> metavar "ALG"
+          )
+        <*> strOption
+          ( long "ip"
+              <> help
+                "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
+              <> value "127.0.0.1"
+              <> showDefault
+              <> metavar "IP"
+          )
+        <*> (optional . strOption)
+          ( long "fqdn"
+              <> short 'n'
+              <> help "Server FQDN used as Common Name for TLS online certificate"
+              <> showDefault
+              <> metavar "FQDN"
+          )
+        <*> strOption
+          ( long "path"
+              <> short 'p'
+              <> help "Path to the directory to store files"
+              <> metavar "PATH"
+          )
+        <*> strOption
+          ( long "quota"
+              <> short 'q'
+              <> help "File storage quota (e.g. 100gb)"
+              <> metavar "QUOTA"
+          )

src/Simplex/FileTransfer/Server/Stats.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Server.Stats where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
+import Data.Time.Clock (UTCTime)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (SenderId)
+import Simplex.Messaging.Server.Stats (PeriodStats, PeriodStatsData, getPeriodStatsData, newPeriodStats, setPeriodStats)
+import UnliftIO.STM
+
+data FileServerStats = FileServerStats
+  { fromTime :: TVar UTCTime,
+    filesCreated :: TVar Int,
+    fileRecipients :: TVar Int,
+    filesUploaded :: TVar Int,
+    filesDeleted :: TVar Int,
+    filesDownloaded :: PeriodStats SenderId,
+    fileDownloads :: TVar Int,
+    fileDownloadAcks :: TVar Int,
+    filesCount :: TVar Int,
+    filesSize :: TVar Int64
+  }
+
+data FileServerStatsData = FileServerStatsData
+  { _fromTime :: UTCTime,
+    _filesCreated :: Int,
+    _fileRecipients :: Int,
+    _filesUploaded :: Int,
+    _filesDeleted :: Int,
+    _filesDownloaded :: PeriodStatsData SenderId,
+    _fileDownloads :: Int,
+    _fileDownloadAcks :: Int,
+    _filesCount :: Int,
+    _filesSize :: Int64
+  }
+  deriving (Show)
+
+newFileServerStats :: UTCTime -> STM FileServerStats
+newFileServerStats ts = do
+  fromTime <- newTVar ts
+  filesCreated <- newTVar 0
+  fileRecipients <- newTVar 0
+  filesUploaded <- newTVar 0
+  filesDeleted <- newTVar 0
+  filesDownloaded <- newPeriodStats
+  fileDownloads <- newTVar 0
+  fileDownloadAcks <- newTVar 0
+  filesCount <- newTVar 0
+  filesSize <- newTVar 0
+  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
+
+getFileServerStatsData :: FileServerStats -> STM FileServerStatsData
+getFileServerStatsData s = do
+  _fromTime <- readTVar $ fromTime (s :: FileServerStats)
+  _filesCreated <- readTVar $ filesCreated s
+  _fileRecipients <- readTVar $ fileRecipients s
+  _filesUploaded <- readTVar $ filesUploaded s
+  _filesDeleted <- readTVar $ filesDeleted s
+  _filesDownloaded <- getPeriodStatsData $ filesDownloaded s
+  _fileDownloads <- readTVar $ fileDownloads s
+  _fileDownloadAcks <- readTVar $ fileDownloadAcks s
+  _filesCount <- readTVar $ filesCount s
+  _filesSize <- readTVar $ filesSize s
+  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
+
+setFileServerStats :: FileServerStats -> FileServerStatsData -> STM ()
+setFileServerStats s d = do
+  writeTVar (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData)
+  writeTVar (filesCreated s) $! _filesCreated d
+  writeTVar (fileRecipients s) $! _fileRecipients d
+  writeTVar (filesUploaded s) $! _filesUploaded d
+  writeTVar (filesDeleted s) $! _filesDeleted d
+  setPeriodStats (filesDownloaded s) $! _filesDownloaded d
+  writeTVar (fileDownloads s) $! _fileDownloads d
+  writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d
+  writeTVar (filesCount s) $! _filesCount d
+  writeTVar (filesSize s) $! _filesSize d
+
+instance StrEncoding FileServerStatsData where
+  strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks} =
+    B.unlines
+      [ "fromTime=" <> strEncode _fromTime,
+        "filesCreated=" <> strEncode _filesCreated,
+        "fileRecipients=" <> strEncode _fileRecipients,
+        "filesUploaded=" <> strEncode _filesUploaded,
+        "filesDeleted=" <> strEncode _filesDeleted,
+        "filesDownloaded:",
+        strEncode _filesDownloaded,
+        "fileDownloads=" <> strEncode _fileDownloads,
+        "fileDownloadAcks=" <> strEncode _fileDownloadAcks
+      ]
+  strP = do
+    _fromTime <- "fromTime=" *> strP <* A.endOfLine
+    _filesCreated <- "filesCreated=" *> strP <* A.endOfLine
+    _fileRecipients <- "fileRecipients=" *> strP <* A.endOfLine
+    _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine
+    _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine
+    _filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine
+    _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine
+    _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine
+    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount = 0, _filesSize = 0}

src/Simplex/FileTransfer/Server/Store.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.FileTransfer.Server.Store
+  ( FileStore (..),
+    FileRec (..),
+    FileRecipient (..),
+    newFileStore,
+    addFile,
+    setFilePath,
+    setFilePath',
+    addRecipient,
+    deleteFile,
+    deleteRecipient,
+    expiredFilePath,
+    getFile,
+    ackFile,
+  )
+where
+
+import Control.Concurrent.STM
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time.Clock.System (SystemTime (..))
+import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (ifM, ($>>=))
+
+data FileStore = FileStore
+  { files :: TMap SenderId FileRec,
+    recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey),
+    usedStorage :: TVar Int64
+  }
+
+data FileRec = FileRec
+  { senderId :: SenderId,
+    fileInfo :: FileInfo,
+    filePath :: TVar (Maybe FilePath),
+    recipientIds :: TVar (Set RecipientId),
+    createdAt :: SystemTime
+  }
+  deriving (Eq)
+
+data FileRecipient = FileRecipient RecipientId RcvPublicVerifyKey
+
+instance StrEncoding FileRecipient where
+  strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey
+  strP = FileRecipient <$> strP <* A.char ':' <*> strP
+
+newFileStore :: STM FileStore
+newFileStore = do
+  files <- TM.empty
+  recipients <- TM.empty
+  usedStorage <- newTVar 0
+  pure FileStore {files, recipients, usedStorage}
+
+addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ())
+addFile FileStore {files} sId fileInfo createdAt =
+  ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
+    f <- newFileRec sId fileInfo createdAt
+    TM.insert sId f files
+    pure $ Right ()
+
+newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec
+newFileRec senderId fileInfo createdAt = do
+  recipientIds <- newTVar S.empty
+  filePath <- newTVar Nothing
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt}
+
+setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ())
+setFilePath st sId fPath =
+  withFile st sId $ \fr -> setFilePath' st fr fPath $> Right ()
+
+setFilePath' :: FileStore -> FileRec -> FilePath -> STM ()
+setFilePath' st FileRec {fileInfo, filePath} fPath = do
+  writeTVar filePath (Just fPath)
+  modifyTVar' (usedStorage st) (+ fromIntegral (size fileInfo))
+
+addRecipient :: FileStore -> SenderId -> FileRecipient -> STM (Either XFTPErrorType ())
+addRecipient st@FileStore {recipients} senderId (FileRecipient rId rKey) =
+  withFile st senderId $ \FileRec {recipientIds} -> do
+    rIds <- readTVar recipientIds
+    mem <- TM.member rId recipients
+    if rId `S.member` rIds || mem
+      then pure $ Left DUPLICATE_
+      else do
+        writeTVar recipientIds $! S.insert rId rIds
+        TM.insert rId (senderId, rKey) recipients
+        pure $ Right ()
+
+-- this function must be called after the file is deleted from the file system
+deleteFile :: FileStore -> SenderId -> STM (Either XFTPErrorType ())
+deleteFile FileStore {files, recipients, usedStorage} senderId = do
+  TM.lookupDelete senderId files >>= \case
+    Just FileRec {fileInfo, recipientIds} -> do
+      readTVar recipientIds >>= mapM_ (`TM.delete` recipients)
+      modifyTVar' usedStorage $ subtract (fromIntegral $ size fileInfo)
+      pure $ Right ()
+    _ -> pure $ Left AUTH
+
+deleteRecipient :: FileStore -> RecipientId -> FileRec -> STM ()
+deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do
+  TM.delete rId recipients
+  modifyTVar' recipientIds $ S.delete rId
+
+getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey))
+getFile st party fId = case party of
+  SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
+  SFRecipient ->
+    TM.lookup fId (recipients st) >>= \case
+      Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey)
+      _ -> pure $ Left AUTH
+
+expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe FilePath)
+expiredFilePath FileStore {files} sId old =
+  TM.lookup sId files
+    $>>= \FileRec {filePath, createdAt} ->
+      if systemSeconds createdAt < old
+        then readTVar filePath
+        else pure Nothing
+
+ackFile :: FileStore -> RecipientId -> STM (Either XFTPErrorType ())
+ackFile st@FileStore {recipients} recipientId = do
+  TM.lookupDelete recipientId recipients >>= \case
+    Just (sId, _) ->
+      withFile st sId $ \FileRec {recipientIds} -> do
+        modifyTVar' recipientIds $ S.delete recipientId
+        pure $ Right ()
+    _ -> pure $ Left AUTH
+
+withFile :: FileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a)
+withFile FileStore {files} sId a =
+  TM.lookup sId files >>= \case
+    Just f -> a f
+    _ -> pure $ Left AUTH

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Server.StoreLog
+  ( StoreLog,
+    FileStoreLogRecord (..),
+    closeStoreLog,
+    readWriteFileStore,
+    logAddFile,
+    logPutFile,
+    logAddRecipients,
+    logDeleteFile,
+    logAckFile,
+  )
+where
+
+import Control.Concurrent.STM
+import Control.Monad.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Char8 as B
+import Data.Composition ((.:), (.:.))
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Time.Clock.System (SystemTime)
+import Simplex.FileTransfer.Protocol (FileInfo (..))
+import Simplex.FileTransfer.Server.Store
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.Util (bshow, whenM)
+import System.Directory (doesFileExist, renameFile)
+import System.IO
+
+data FileStoreLogRecord
+  = AddFile SenderId FileInfo SystemTime
+  | PutFile SenderId FilePath
+  | AddRecipients SenderId (NonEmpty FileRecipient)
+  | DeleteFile SenderId
+  | AckFile RecipientId
+
+instance StrEncoding FileStoreLogRecord where
+  strEncode = \case
+    AddFile sId file createdAt -> strEncode (Str "FNEW", sId, file, createdAt)
+    PutFile sId path -> strEncode (Str "FPUT", sId, path)
+    AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps)
+    DeleteFile sId -> strEncode (Str "FDEL", sId)
+    AckFile rId -> strEncode (Str "FACK", rId)
+  strP =
+    A.choice
+      [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP),
+        "FPUT " *> (PutFile <$> strP_ <*> strP),
+        "FADD " *> (AddRecipients <$> strP_ <*> strP),
+        "FDEL " *> (DeleteFile <$> strP),
+        "FACK " *> (AckFile <$> strP)
+      ]
+
+logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
+logFileStoreRecord = writeStoreLogRecord
+
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO ()
+logAddFile s = logFileStoreRecord s .:. AddFile
+
+logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
+logPutFile s = logFileStoreRecord s .: PutFile
+
+logAddRecipients :: StoreLog 'WriteMode -> SenderId -> NonEmpty FileRecipient -> IO ()
+logAddRecipients s = logFileStoreRecord s .: AddRecipients
+
+logDeleteFile :: StoreLog 'WriteMode -> SenderId -> IO ()
+logDeleteFile s = logFileStoreRecord s . DeleteFile
+
+logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
+logAckFile s = logFileStoreRecord s . AckFile
+
+readWriteFileStore :: FilePath -> FileStore -> IO (StoreLog 'WriteMode)
+readWriteFileStore f st = do
+  whenM (doesFileExist f) $ do
+    readFileStore f st
+    renameFile f $ f <> ".bak"
+  s <- openWriteStoreLog f
+  writeFileStore s st
+  pure s
+
+readFileStore :: FilePath -> FileStore -> IO ()
+readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f
+  where
+    addFileLogRecord s = case strDecode s of
+      Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
+      Right lr ->
+        atomically (addToStore lr) >>= \case
+          Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
+          _ -> pure ()
+    addToStore = \case
+      AddFile sId file createdAt -> addFile st sId file createdAt
+      PutFile qId path -> setFilePath st qId path
+      AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps
+      DeleteFile sId -> deleteFile st sId
+      AckFile rId -> ackFile st rId
+    addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps
+
+writeFileStore :: StoreLog 'WriteMode -> FileStore -> IO ()
+writeFileStore s FileStore {files, recipients} = do
+  allRcps <- readTVarIO recipients
+  readTVarIO files >>= mapM_ (logFile allRcps)
+  where
+    logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO ()
+    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do
+      logAddFile s senderId fileInfo createdAt
+      (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds
+      mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps
+      mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs
+      readTVarIO filePath >>= mapM_ (logPutFile s senderId)
+      where
+        getRcp rId = case M.lookup rId allRcps of
+          Just (sndId, rKey)
+            | sndId == senderId -> Right $ FileRecipient rId rKey
+            | otherwise -> Left $ "sender ID for recipient ID " <> bshow rId <> " does not match FileRec"
+          Nothing -> Left $ "recipient ID " <> bshow rId <> " not found"

src/Simplex/FileTransfer/Transport.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Transport
+  ( supportedFileServerVRange,
+    XFTPRcvChunkSpec (..),
+    sendFile,
+    receiveFile,
+    sendEncFile,
+    receiveEncFile,
+  )
+where
+
+import qualified Control.Exception as E
+import Control.Monad.Except
+import qualified Data.ByteArray as BA
+import Data.ByteString.Builder (Builder, byteString)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Word (Word32)
+import GHC.IO.Handle.Internals (ioe_EOF)
+import Simplex.FileTransfer.Protocol (XFTPErrorType (..))
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Version
+import System.IO (Handle, IOMode (..), withFile)
+
+data XFTPRcvChunkSpec = XFTPRcvChunkSpec
+  { filePath :: FilePath,
+    chunkSize :: Word32,
+    chunkDigest :: ByteString
+  }
+  deriving (Show)
+
+supportedFileServerVRange :: VersionRange
+supportedFileServerVRange = mkVersionRange 1 1
+
+fileBlockSize :: Int
+fileBlockSize = 16 * 1024
+
+sendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
+sendFile h send = go
+  where
+    go 0 = pure ()
+    go sz =
+      getFileChunk h sz >>= \ch -> do
+        send $ byteString ch
+        go $ sz - fromIntegral (B.length ch)
+
+sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
+sendEncFile h send = go
+  where
+    go sbState 0 = do
+      let authTag = BA.convert (LC.sbAuth sbState)
+      send $ byteString authTag
+    go sbState sz =
+      getFileChunk h sz >>= \ch -> do
+        let (encCh, sbState') = LC.sbEncryptChunk sbState ch
+        send (byteString encCh) `E.catch` \(e :: E.SomeException) -> print e >> E.throwIO e
+        go sbState' $ sz - fromIntegral (B.length ch)
+
+getFileChunk :: Handle -> Word32 -> IO ByteString
+getFileChunk h sz =
+  B.hGet h fileBlockSize >>= \case
+    "" -> ioe_EOF
+    ch -> pure $ B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
+
+receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
+receiveFile getBody = receiveFile_ receive
+  where
+    receive h sz = do
+      ch <- getBody fileBlockSize
+      let chSize = fromIntegral $ B.length ch
+      if
+          | chSize > sz -> pure $ Left SIZE
+          | chSize > 0 -> B.hPut h ch >> receive h (sz - chSize)
+          | sz == 0 -> pure $ Right ()
+          | otherwise -> pure $ Left SIZE
+
+receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
+receiveEncFile getBody = receiveFile_ . receive
+  where
+    receive sbState h sz = do
+      ch <- getBody fileBlockSize
+      let chSize = fromIntegral $ B.length ch
+      if
+          | chSize > sz + authSz -> pure $ Left SIZE
+          | chSize > 0 -> do
+            let (ch', rest) = B.splitAt (fromIntegral sz) ch
+                (decCh, sbState') = LC.sbDecryptChunk sbState ch'
+                sz' = sz - fromIntegral (B.length ch')
+            B.hPut h decCh
+            if sz' > 0
+              then receive sbState' h sz'
+              else do
+                let tag' = B.take C.authTagSize rest
+                    tagSz = B.length tag'
+                    tag = LC.sbAuth sbState'
+                tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz)
+                pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO
+          | otherwise -> pure $ Left SIZE
+    authSz = fromIntegral C.authTagSize
+
+receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
+receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
+  ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
+  digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath
+  when (digest' /= chunkDigest) $ throwError DIGEST

src/Simplex/FileTransfer/Types.hs

@@ -0,0 +1,184 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Types where
+
+import Data.Int (Int64)
+import Data.Word (Word32)
+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 qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (fromTextField_)
+import Simplex.Messaging.Protocol
+
+authTagSize :: Int64
+authTagSize = fromIntegral C.authTagSize
+
+-- fileExtra is added to allow header extension in future versions
+data FileHeader = FileHeader
+  { fileName :: String,
+    fileExtra :: Maybe String
+  }
+  deriving (Eq, Show)
+
+instance Encoding FileHeader where
+  smpEncode FileHeader {fileName, fileExtra} = smpEncode (fileName, fileExtra)
+  smpP = do
+    (fileName, fileExtra) <- smpP
+    pure FileHeader {fileName, fileExtra}
+
+type DBRcvFileId = Int64
+
+data RcvFile = RcvFile
+  { rcvFileId :: DBRcvFileId,
+    rcvFileEntityId :: RcvFileId,
+    userId :: Int64,
+    size :: FileSize Int64,
+    digest :: FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: FileSize Word32,
+    chunks :: [RcvFileChunk],
+    prefixPath :: FilePath,
+    tmpPath :: Maybe FilePath,
+    savePath :: FilePath,
+    status :: RcvFileStatus,
+    deleted :: Bool
+  }
+  deriving (Eq, Show)
+
+data RcvFileStatus
+  = RFSReceiving
+  | RFSReceived
+  | RFSDecrypting
+  | RFSComplete
+  | RFSError
+  deriving (Eq, Show)
+
+instance FromField RcvFileStatus where fromField = fromTextField_ textDecode
+
+instance ToField RcvFileStatus where toField = toField . textEncode
+
+instance TextEncoding RcvFileStatus where
+  textDecode = \case
+    "receiving" -> Just RFSReceiving
+    "received" -> Just RFSReceived
+    "decrypting" -> Just RFSDecrypting
+    "complete" -> Just RFSComplete
+    "error" -> Just RFSError
+    _ -> Nothing
+  textEncode = \case
+    RFSReceiving -> "receiving"
+    RFSReceived -> "received"
+    RFSDecrypting -> "decrypting"
+    RFSComplete -> "complete"
+    RFSError -> "error"
+
+data RcvFileChunk = RcvFileChunk
+  { rcvFileId :: DBRcvFileId,
+    rcvFileEntityId :: RcvFileId,
+    userId :: Int64,
+    rcvChunkId :: Int64,
+    chunkNo :: Int,
+    chunkSize :: FileSize Word32,
+    digest :: FileDigest,
+    replicas :: [RcvFileChunkReplica],
+    fileTmpPath :: FilePath,
+    chunkTmpPath :: Maybe FilePath
+  }
+  deriving (Eq, Show)
+
+data RcvFileChunkReplica = RcvFileChunkReplica
+  { rcvChunkReplicaId :: Int64,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    received :: Bool,
+    delay :: Maybe Int,
+    retries :: Int
+  }
+  deriving (Eq, Show)
+
+-- Sending files
+
+type DBSndFileId = Int64
+
+data SndFile = SndFile
+  { userId :: Int64,
+    sndFileId :: DBSndFileId,
+    size :: FileSize Int64,
+    digest :: FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: FileSize Word32,
+    chunks :: [RcvFileChunk],
+    path :: FilePath,
+    encPath :: Maybe FilePath,
+    status :: SndFileStatus
+  }
+  deriving (Eq, Show)
+
+data SndFileStatus
+  = SFSNew
+  | SFSEncrypting
+  | SFSEncrypted
+  | SFSUploading
+  | SFSComplete
+  deriving (Eq, Show)
+
+instance FromField SndFileStatus where fromField = fromTextField_ textDecode
+
+instance ToField SndFileStatus where toField = toField . textEncode
+
+instance TextEncoding SndFileStatus where
+  textDecode = \case
+    "new" -> Just SFSNew
+    "encrypting" -> Just SFSEncrypting
+    "encrypted" -> Just SFSEncrypted
+    "uploading" -> Just SFSUploading
+    "complete" -> Just SFSComplete
+    _ -> Nothing
+  textEncode = \case
+    SFSNew -> "new"
+    SFSEncrypting -> "encrypting"
+    SFSEncrypted -> "encrypted"
+    SFSUploading -> "uploading"
+    SFSComplete -> "complete"
+
+data SndFileChunk = SndFileChunk
+  { userId :: Int64,
+    sndFileId :: DBSndFileId,
+    sndChunkId :: Int64,
+    chunkNo :: Int,
+    chunkSpec :: XFTPChunkSpec,
+    digest :: FileDigest,
+    replicas :: [SndFileChunkReplica],
+    delay :: Maybe Int
+  }
+  deriving (Eq, Show)
+
+data SndFileChunkReplica = SndFileChunkReplica
+  { sndChunkReplicaId :: Int64,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)],
+    -- created :: Bool,
+    uploaded :: Bool,
+    retries :: Int
+  }
+  deriving (Eq, Show)
+
+-- to be used in reply to client
+data SndFileDescription = SndFileDescription
+  { description :: String,
+    sender :: Bool
+  }
+  deriving (Eq, Show)

src/Simplex/FileTransfer/Util.hs

@@ -0,0 +1,24 @@
+module Simplex.FileTransfer.Util
+  ( uniqueCombine,
+    removePath,
+  )
+where
+
+import Simplex.Messaging.Util (ifM, whenM)
+import System.FilePath (splitExtensions, (</>))
+import UnliftIO
+import UnliftIO.Directory
+
+uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
+uniqueCombine filePath fileName = tryCombine (0 :: Int)
+  where
+    tryCombine n =
+      let (name, ext) = splitExtensions fileName
+          suffix = if n == 0 then "" else "_" <> show n
+          f = filePath </> (name <> suffix <> ext)
+       in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f)
+
+removePath :: MonadIO m => FilePath -> m ()
+removePath p = do
+  ifM (doesDirectoryExist p) (removeDirectoryRecursive p) $
+    whenM (doesFileExist p) (removeFile p)

src/Simplex/Messaging/Agent.hs

@@ -80,6 +80,9 @@ module Simplex.Messaging.Agent
     getNtfToken,
     getNtfTokenData,
     toggleConnectionNtfs,
+    xftpReceiveFile,
+    xftpDeleteRcvFile,
+    xftpSendFile,
     activateAgent,
     suspendAgent,
     execAgentStoreSQL,
@@ -113,6 +116,10 @@ import qualified Data.Text as T
 import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
 import qualified Database.SQLite.Simple as DB
+import Simplex.FileTransfer.Agent (addXFTPWorker, deleteRcvFile, receiveFile, sendFileExperimental)
+import Simplex.FileTransfer.Description (ValidFileDescription)
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Util (removePath)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock (withLock)
@@ -130,7 +137,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr')
+import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr')
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util
@@ -150,7 +157,17 @@ getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent
     runAgent = do
       c <- getAgentClient initServers
       void $ raceAny_ [subscriber c, runNtfSupervisor c, cleanupManager c] `forkFinally` const (disconnectAgentClient c)
+      runExceptT (startFiles c) >>= \case
+        Left e -> liftIO $ print e
+        Right _ -> pure ()
       pure c
+    startFiles c = do
+      pendingRcvServers <- withStore' c getPendingRcvFilesServers
+      forM_ pendingRcvServers $ \s -> addXFTPWorker 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
 
 disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m ()
 disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns}} = do
@@ -276,18 +293,18 @@ getConnectionRatchetAdHash :: AgentErrorMonad m => AgentClient -> ConnId -> m By
 getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
 
 -- | Change servers to be used for creating new queues
-setSMPServers :: AgentErrorMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
+setSMPServers :: MonadUnliftIO m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
 setSMPServers c = withAgentEnv c .: setSMPServers' c
 
 -- | Test SMP server
 testSMPServerConnection :: AgentErrorMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
 testSMPServerConnection c = withAgentEnv c .: runSMPServerTest c
 
-setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
+setNtfServers :: MonadUnliftIO m => AgentClient -> [NtfServer] -> m ()
 setNtfServers c = withAgentEnv c . setNtfServers' c
 
 -- | set SOCKS5 proxy on/off and optionally set TCP timeout
-setNetworkConfig :: AgentErrorMonad m => AgentClient -> NetworkConfig -> m ()
+setNetworkConfig :: MonadUnliftIO m => AgentClient -> NetworkConfig -> m ()
 setNetworkConfig c cfg' = do
   cfg <- atomically $ do
     swapTVar (useNetworkConfig c) cfg'
@@ -322,31 +339,43 @@ getNtfTokenData c = withAgentEnv c $ getNtfTokenData' c
 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
+
+-- | Delete XFTP rcv file (deletes work files from file system and db records)
+xftpDeleteRcvFile :: AgentErrorMonad m => AgentClient -> UserId -> RcvFileId -> m ()
+xftpDeleteRcvFile c = withAgentEnv c .: deleteRcvFile c
+
+-- | Send XFTP file
+xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId
+xftpSendFile c = withAgentEnv c .:: sendFileExperimental c
+
 -- | Activate operations
-activateAgent :: AgentErrorMonad m => AgentClient -> m ()
+activateAgent :: MonadUnliftIO m => AgentClient -> m ()
 activateAgent c = withAgentEnv c $ activateAgent' c
 
 -- | Suspend operations with max delay to deliver pending messages
-suspendAgent :: AgentErrorMonad m => AgentClient -> Int -> m ()
+suspendAgent :: MonadUnliftIO m => AgentClient -> Int -> m ()
 suspendAgent c = withAgentEnv c . suspendAgent' c
 
 execAgentStoreSQL :: AgentErrorMonad m => AgentClient -> Text -> m [Text]
 execAgentStoreSQL c = withAgentEnv c . execAgentStoreSQL' c
 
-debugAgentLocks :: AgentErrorMonad m => AgentClient -> m AgentLocks
+debugAgentLocks :: MonadUnliftIO m => AgentClient -> m AgentLocks
 debugAgentLocks c = withAgentEnv c $ debugAgentLocks' c
 
-getAgentStats :: AgentErrorMonad m => AgentClient -> m [(AgentStatsKey, Int)]
+getAgentStats :: MonadIO m => AgentClient -> m [(AgentStatsKey, Int)]
 getAgentStats c = readTVarIO (agentStats c) >>= mapM (\(k, cnt) -> (k,) <$> readTVarIO cnt) . M.assocs
 
-resetAgentStats :: AgentErrorMonad m => AgentClient -> m ()
+resetAgentStats :: MonadIO m => AgentClient -> m ()
 resetAgentStats = atomically . TM.clear . agentStats
 
 withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
 withAgentEnv c = (`runReaderT` agentEnv c)
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
-getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => InitialAgentServers -> m AgentClient
+getAgentClient :: AgentMonad' m => InitialAgentServers -> m AgentClient
 getAgentClient initServers = ask >>= atomically . newAgentClient initServers
 
 logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
@@ -355,34 +384,36 @@ logConnection c connected =
    in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"]
 
 -- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
-runAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runAgentClient :: AgentMonad' m => AgentClient -> m ()
 runAgentClient c = race_ (subscriber c) (client c)
 
-client :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+client :: forall m. AgentMonad' m => AgentClient -> m ()
 client c@AgentClient {rcvQ, subQ} = forever $ do
-  (corrId, connId, cmd) <- atomically $ readTBQueue rcvQ
-  runExceptT (processCommand c (connId, cmd))
+  (corrId, entId, cmd) <- atomically $ readTBQueue rcvQ
+  runExceptT (processCommand c (entId, cmd))
     >>= atomically . writeTBQueue subQ . \case
-      Left e -> (corrId, connId, ERR e)
-      Right (connId', resp) -> (corrId, connId', resp)
+      Left e -> (corrId, entId, APC SAEConn $ ERR e)
+      Right (entId', resp) -> (corrId, entId', resp)
 
 -- | execute any SMP agent command
-processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent)
-processCommand c (connId, cmd) = case cmd of
-  NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing
-  JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo
-  LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)
-  ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo
-  RJCT invId -> rejectContact' c connId invId $> (connId, OK)
-  SUB -> subscribeConnection' c connId $> (connId, OK)
-  SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody
-  ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
-  SWCH -> switchConnection' c connId $> (connId, OK)
-  OFF -> suspendConnection' c connId $> (connId, OK)
-  DEL -> deleteConnection' c connId $> (connId, OK)
-  CHK -> (connId,) . STAT <$> getConnectionServers' c connId
+processCommand :: forall m. AgentMonad m => AgentClient -> (EntityId, APartyCmd 'Client) -> m (EntityId, APartyCmd 'Agent)
+processCommand c (connId, APC e cmd) =
+  second (APC e) <$> case cmd of
+    NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing
+    JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo
+    LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)
+    ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo
+    RJCT invId -> rejectContact' c connId invId $> (connId, OK)
+    SUB -> subscribeConnection' c connId $> (connId, OK)
+    SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody
+    ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
+    SWCH -> switchConnection' c connId $> (connId, OK)
+    OFF -> suspendConnection' c connId $> (connId, OK)
+    DEL -> deleteConnection' c connId $> (connId, OK)
+    CHK -> (connId,) . STAT <$> getConnectionServers' c connId
   where
     -- command interface does not support different users
+    userId :: UserId
     userId = 1
 
 createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId
@@ -400,12 +431,12 @@ deleteUser' c userId delSMPQueues = do
   where
     delUser =
       whenM (withStore' c (`deleteUserWithoutConns` userId)) $
-        atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId)
+        atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
 
 newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId
 newConnAsync c userId corrId enableNtfs cMode = do
   connId <- newConnNoQueues c userId "" enableNtfs cMode
-  enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode)
+  enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode)
   pure connId
 
 newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> m ConnId
@@ -424,7 +455,7 @@ joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData
       let duplexHS = connAgentVersion /= 1
           cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False}
       connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation
-      enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo
+      enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo
       pure connId
     _ -> throwError $ AGENT A_VERSION
 joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _cInfo =
@@ -434,7 +465,7 @@ allowConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> Con
 allowConnectionAsync' c corrId connId confId ownConnInfo =
   withStore c (`getConn` connId) >>= \case
     SomeConn _ (RcvConnection _ RcvQueue {server}) ->
-      enqueueCommand c corrId connId (Just server) $ AClientCommand $ LET confId ownConnInfo
+      enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo
     _ -> throwError $ CMD PROHIBITED
 
 acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> m ConnId
@@ -461,7 +492,7 @@ ackMessageAsync' c corrId connId msgId = do
     enqueueAck :: m ()
     enqueueAck = do
       (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId
-      enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId
+      enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId
 
 deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
 deleteConnectionAsync' c connId = deleteConnectionsAsync' c [connId]
@@ -483,7 +514,7 @@ deleteConnectionsAsync_ onSuccess c connIds = case connIds of
 switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m ()
 switchConnectionAsync' c corrId connId =
   withStore c (`getConn` connId) >>= \case
-    SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand SWCH
+    SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
     _ -> throwError $ CMD PROHIBITED
 
 newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c)
@@ -689,7 +720,7 @@ subscribeConnections' c connIds = do
       let actual = M.size rs
           expected = length connIds
       when (actual /= expected) . atomically $
-        writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
+        writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
 
 resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
 resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId]
@@ -777,10 +808,10 @@ resumeConnCmds c connId =
       queuePendingCommands c srv cmdIds
     connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
 
-cmdProcessExists :: AgentMonad m => AgentClient -> Maybe SMPServer -> m Bool
+cmdProcessExists :: AgentMonad' m => AgentClient -> Maybe SMPServer -> m Bool
 cmdProcessExists c srv = atomically $ TM.member srv (asyncCmdProcesses c)
 
-queuePendingCommands :: AgentMonad m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m ()
+queuePendingCommands :: AgentMonad' m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m ()
 queuePendingCommands c server cmdIds = atomically $ do
   q <- getPendingCommandQ c server
   mapM_ (writeTQueue q) cmdIds
@@ -804,12 +835,12 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
     cmdId <- atomically $ readTQueue cq
     atomically $ beginAgentOperation c AOSndNetwork
     E.try (withStore c $ \db -> getPendingCommand db cmdId) >>= \case
-      Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", ERR . INTERNAL $ show e)
+      Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ INTERNAL $ show e)
       Right cmd -> processCmd (riFast ri) cmdId cmd
   where
     processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m ()
     processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of
-      AClientCommand cmd -> case cmd of
+      AClientCommand (APC _ cmd) -> case cmd of
         NEW enableNtfs (ACM cMode) -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
           tryCommand . withNextSrv usedSrvs [] $ \srv -> do
@@ -896,7 +927,8 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
         tryWithLock name = tryCommand . withConnLock c connId name
         internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
         cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
-        notify cmd = atomically $ writeTBQueue subQ (corrId, connId, cmd)
+        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+        notify cmd = atomically $ writeTBQueue subQ (corrId, connId, APC (sAEntity @e) cmd)
         withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m ()
         withNextSrv usedSrvs initUsed action = do
           used <- readTVarIO usedSrvs
@@ -959,7 +991,7 @@ resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
     queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c)
     msgsQueued = atomically $ isJust <$> TM.lookupInsert (server, sndId) True (pendingMsgsQueued c)
 
-queuePendingMsgs :: AgentMonad m => AgentClient -> SndQueue -> [InternalId] -> m ()
+queuePendingMsgs :: AgentMonad' m => AgentClient -> SndQueue -> [InternalId] -> m ()
 queuePendingMsgs c sq msgIds = atomically $ do
   modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds}
   -- s <- readTVar (msgDeliveryOp c)
@@ -1105,9 +1137,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
   where
     delMsg :: InternalId -> m ()
     delMsg msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId
-    notify :: ACommand 'Agent -> m ()
-    notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd)
-    notifyDel :: InternalId -> ACommand 'Agent -> m ()
+    notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+    notify cmd = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) cmd)
+    notifyDel :: AEntityI e => InternalId -> ACommand 'Agent e -> m ()
     notifyDel msgId cmd = notify cmd >> delMsg msgId
     connError msgId = notifyDel msgId . ERR . CONN
     qError msgId = notifyDel msgId . ERR . AGENT . A_QUEUE
@@ -1226,7 +1258,7 @@ deleteConnQueues :: forall m. AgentMonad m => AgentClient -> Bool -> [RcvQueue]
 deleteConnQueues c ntf rqs = do
   rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs)
   forM_ (M.assocs rs) $ \case
-    (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, DEL_CONN)
+    (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, APC SAEConn DEL_CONN)
     _ -> pure ()
   pure rs
   where
@@ -1240,7 +1272,7 @@ deleteConnQueues c ntf rqs = do
             | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> withStore' c (`incRcvDeleteErrors` rq) $> r
             | otherwise -> withStore' c (`deleteConnRcvQueue` rq) >> notifyRQ rq (Just e) $> Right ()
         pure (rq, r')
-    notifyRQ rq e_ = notify ("", qConnId rq, DEL_RCVQ (qServer rq) (queueId rq) e_)
+    notifyRQ rq e_ = notify ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_)
     notify = when ntf . atomically . writeTBQueue (subQ c)
     connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
     connResults = M.map snd . foldl' addResult M.empty
@@ -1278,7 +1310,7 @@ deleteConnections_ getConnections ntf c connIds = do
       let actual = M.size rs
           expected = length connIds
       when (actual /= expected) . atomically $
-        writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected)
+        writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected)
 
 getConnectionServers' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
 getConnectionServers' c connId = do
@@ -1299,7 +1331,7 @@ connectionStats = \case
   NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
 
 -- | Change servers to be used for creating new queues, in Reader monad
-setSMPServers' :: AgentMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
+setSMPServers' :: AgentMonad' m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
 setSMPServers' c userId srvs = atomically $ TM.insert userId srvs $ smpServers c
 
 registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
@@ -1494,19 +1526,19 @@ sendNtfConnCommands c cmd = do
       Just (ConnData {enableNtfs}, _) ->
         when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
       _ ->
-        atomically $ writeTBQueue (subQ c) ("", connId, ERR $ INTERNAL "no connection data")
+        atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn $ ERR $ INTERNAL "no connection data")
 
-setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m ()
+setNtfServers' :: AgentMonad' m => AgentClient -> [NtfServer] -> m ()
 setNtfServers' c = atomically . writeTVar (ntfServers c)
 
-activateAgent' :: AgentMonad m => AgentClient -> m ()
+activateAgent' :: AgentMonad' m => AgentClient -> m ()
 activateAgent' c = do
   atomically $ writeTVar (agentState c) ASActive
   mapM_ activate $ reverse agentOperations
   where
     activate opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = False}
 
-suspendAgent' :: AgentMonad m => AgentClient -> Int -> m ()
+suspendAgent' :: AgentMonad' m => AgentClient -> Int -> m ()
 suspendAgent' c 0 = do
   atomically $ writeTVar (agentState c) ASSuspended
   mapM_ suspend agentOperations
@@ -1531,7 +1563,7 @@ suspendAgent' c@AgentClient {agentState = as} maxDelay = do
 execAgentStoreSQL' :: AgentMonad m => AgentClient -> Text -> m [Text]
 execAgentStoreSQL' c sql = withStore' c (`execSQL` sql)
 
-debugAgentLocks' :: AgentMonad m => AgentClient -> m AgentLocks
+debugAgentLocks' :: AgentMonad' m => AgentClient -> m AgentLocks
 debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock = d} = do
   connLocks <- getLocks cs
   srvLocks <- getLocks rs
@@ -1543,7 +1575,7 @@ debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock =
 getSMPServer :: AgentMonad m => AgentClient -> UserId -> m SMPServerWithAuth
 getSMPServer c userId = withUserServers c userId pickServer
 
-pickServer :: AgentMonad m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth
+pickServer :: AgentMonad' m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth
 pickServer = \case
   srv :| [] -> pure srv
   servers -> do
@@ -1562,7 +1594,7 @@ withUserServers c userId action =
     Just srvs -> action srvs
     _ -> throwError $ INTERNAL "unknown userId - no SMP servers"
 
-subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+subscriber :: AgentMonad' m => AgentClient -> m ()
 subscriber c@AgentClient {msgQ} = forever $ do
   t <- atomically $ readTBQueue msgQ
   agentOperationBracket c AORcvNetwork waitUntilActive $
@@ -1570,18 +1602,32 @@ subscriber c@AgentClient {msgQ} = forever $ do
       Left e -> liftIO $ print e
       Right _ -> return ()
 
-cleanupManager :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+cleanupManager :: AgentMonad' m => AgentClient -> m ()
 cleanupManager c = do
   threadDelay =<< asks (initialCleanupDelay . config)
   int <- asks (cleanupInterval . config)
   forever $ do
-    void . runExceptT $
+    void . runExceptT $ do
+      deleteConns
+      deleteFiles
+      threadDelay int
+  where
+    deleteConns =
       withLock (deleteLock c) "cleanupManager" $ do
         void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
         withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted
-    threadDelay int
-  where
-    notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId)
+    notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
+    deleteFiles = do
+      -- cleanup rcv files marked for deletion
+      rcvDeleted <- withStore' c getCleanupRcvFilesDeleted
+      forM_ rcvDeleted $ \(fId, p) -> do
+        removePath p
+        withStore' c (`deleteRcvFile'` fId)
+      -- cleanup rcv tmp paths
+      rcvTmpPaths <- withStore' c getCleanupRcvFilesTmpPaths
+      forM_ rcvTmpPaths $ \(fId, p) -> do
+        removePath p
+        withStore' c (`updateRcvFileNoTmpPath` fId)
 
 processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
 processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do
@@ -1695,7 +1741,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
               Just (Right clnt)
                 | sessId == sessionId clnt -> do
                   removeSubscription c connId
-                  writeTBQueue subQ ("", connId, END)
+                  notify' END
                   pure "END"
                 | otherwise -> ignored
               _ -> ignored
@@ -1704,8 +1750,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
           logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
           notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED
       where
-        notify :: ACommand 'Agent -> m ()
-        notify msg = atomically $ writeTBQueue subQ ("", connId, msg)
+        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+        notify = atomically . notify'
+
+        notify' :: forall e. AEntityI e => ACommand 'Agent e -> STM ()
+        notify' msg = writeTBQueue subQ ("", connId, APC (sAEntity @e) msg)
 
         prohibited :: m ()
         prohibited = notify . ERR $ AGENT A_PROHIBITED
@@ -1786,7 +1835,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
                   -- this branch is executed by the accepting party in duplexHandshake mode (v2)
                   -- and by the initiating party in v1
                   -- Also see comment where HELLO is sent.
-                  | sndStatus == Active -> atomically $ writeTBQueue subQ ("", connId, CON)
+                  | sndStatus == Active -> notify CON
                   | duplexHandshake == Just True -> enqueueDuplexHello sq
                   | otherwise -> pure ()
                 _ -> pure ()

src/Simplex/Messaging/Agent/Client.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
@@ -24,6 +25,7 @@ module Simplex.Messaging.Agent.Client
     withConnLock,
     closeAgentClient,
     closeProtocolServerClients,
+    closeXFTPServerClient,
     runSMPServerTest,
     newRcvQueue,
     subscribeQueues,
@@ -48,6 +50,7 @@ module Simplex.Messaging.Agent.Client
     agentNtfCreateSubscription,
     agentNtfCheckSubscription,
     agentNtfDeleteSubscription,
+    agentXFTPDownloadChunk,
     agentCbEncrypt,
     agentCbDecrypt,
     cryptoError,
@@ -108,10 +111,17 @@ import Data.Maybe (isJust, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text.Encoding
+import Data.Time (UTCTime)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
 import GHC.Generics (Generic)
 import Network.Socket (HostName)
+import Simplex.FileTransfer.Client (XFTPClient, XFTPClientConfig (..))
+import qualified Simplex.FileTransfer.Client as X
+import Simplex.FileTransfer.Description (ChunkReplicaId (..))
+import Simplex.FileTransfer.Protocol (FileResponse, XFTPErrorType)
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec)
+import Simplex.FileTransfer.Types (RcvFileChunkReplica (..))
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
@@ -151,6 +161,7 @@ import Simplex.Messaging.Protocol
     RcvNtfPublicDhKey,
     SMPMsgMeta (..),
     SndPublicVerifyKey,
+    XFTPServerWithAuth,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
@@ -163,16 +174,20 @@ import UnliftIO (mapConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-type ClientVar err msg = TMVar (Either AgentErrorType (ProtocolClient err msg))
+type ClientVar msg = TMVar (Either AgentErrorType (Client msg))
 
-type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
+type SMPClientVar = ClientVar SMP.BrokerMsg
 
-type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
+type NtfClientVar = ClientVar NtfResponse
+
+type XFTPClientVar = TMVar (Either AgentErrorType XFTPClient)
 
 type SMPTransportSession = TransportSession SMP.BrokerMsg
 
 type NtfTransportSession = TransportSession NtfResponse
 
+type XFTPTransportSession = TransportSession FileResponse
+
 data AgentClient = AgentClient
   { active :: TVar Bool,
     rcvQ :: TBQueue (ATransmission 'Client),
@@ -182,6 +197,8 @@ data AgentClient = AgentClient
     smpClients :: TMap SMPTransportSession SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfTransportSession NtfClientVar,
+    xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth),
+    xftpClients :: TMap XFTPTransportSession XFTPClientVar,
     useNetworkConfig :: TVar NetworkConfig,
     subscrConns :: TVar (Set ConnId),
     activeSubs :: TRcvQueues,
@@ -246,7 +263,7 @@ data AgentStatsKey = AgentStatsKey
   deriving (Eq, Ord, Show)
 
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
-newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
+newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
   active <- newTVar True
   rcvQ <- newTBQueue qSize
@@ -256,6 +273,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   smpClients <- TM.empty
   ntfServers <- newTVar ntf
   ntfClients <- TM.empty
+  xftpServers <- newTVar xftp
+  xftpClients <- TM.empty
   useNetworkConfig <- newTVar netCfg
   subscrConns <- newTVar S.empty
   activeSubs <- RQ.empty
@@ -290,6 +309,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
         smpClients,
         ntfServers,
         ntfClients,
+        xftpServers,
+        xftpClients,
         useNetworkConfig,
         subscrConns,
         activeSubs,
@@ -320,17 +341,41 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
 agentClientStore :: AgentClient -> SQLiteStore
 agentClientStore AgentClient {agentEnv = Env {store}} = store
 
-class ProtocolServerClient err msg | msg -> err where
-  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient err msg)
+class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err where
+  type Client msg = c | c -> msg
+  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (Client msg)
   clientProtocolError :: err -> AgentErrorType
+  closeProtocolServerClient :: Client msg -> IO ()
+  clientServer :: Client msg -> String
+  clientTransportHost :: Client msg -> TransportHost
+  clientSessionTs :: Client msg -> UTCTime
 
 instance ProtocolServerClient ErrorType BrokerMsg where
+  type Client BrokerMsg = ProtocolClient ErrorType BrokerMsg
   getProtocolServerClient = getSMPServerClient
   clientProtocolError = SMP
+  closeProtocolServerClient = closeProtocolClient
+  clientServer = protocolClientServer
+  clientTransportHost = transportHost'
+  clientSessionTs = sessionTs
 
 instance ProtocolServerClient ErrorType NtfResponse where
+  type Client NtfResponse = ProtocolClient ErrorType NtfResponse
   getProtocolServerClient = getNtfServerClient
   clientProtocolError = NTF
+  closeProtocolServerClient = closeProtocolClient
+  clientServer = protocolClientServer
+  clientTransportHost = transportHost'
+  clientSessionTs = sessionTs
+
+instance ProtocolServerClient XFTPErrorType FileResponse where
+  type Client FileResponse = XFTPClient
+  getProtocolServerClient = getXFTPServerClient
+  clientProtocolError = XFTP
+  closeProtocolServerClient = X.closeXFTPClient
+  clientServer = X.xftpClientServer
+  clientTransportHost = X.xftpTransportHost
+  clientSessionTs = X.xftpSessionTs
 
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
 getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
@@ -369,8 +414,8 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv,
             atomically $ mapM_ (releaseGetLock c) qs
             unliftIO u $ reconnectServer c tSess
 
-        notifySub :: ConnId -> ACommand 'Agent -> IO ()
-        notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
+        notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
+        notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
 
 reconnectServer :: AgentMonad m => AgentClient -> SMPTransportSession -> m ()
 reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c
@@ -397,8 +442,8 @@ reconnectSMPClient c tSess@(_, srv, _) =
       let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
       liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
       mapM_ (throwError . snd) $ listToMaybe tempErrs
-    notifySub :: ConnId -> ACommand 'Agent -> IO ()
-    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
+    notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
+    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
 
 getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
 getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
@@ -417,7 +462,28 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
     clientDisconnected client = do
       atomically $ TM.delete tSess ntfClients
       incClientStat c userId client "DISCONNECT" ""
-      atomically $ writeTBQueue (subQ c) ("", "", hostEvent DISCONNECT client)
+      atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
+      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
+
+getXFTPServerClient :: forall m. AgentMonad m => AgentClient -> XFTPTransportSession -> m XFTPClient
+getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do
+  unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
+  atomically (getClientVar tSess xftpClients)
+    >>= either
+      (newProtocolClient c tSess xftpClients connectClient $ \_ _ -> pure ())
+      (waitForProtocolClient c tSess)
+  where
+    connectClient :: m XFTPClient
+    connectClient = do
+      cfg <- asks $ xftpCfg . config
+      xftpNetworkConfig <- readTVarIO useNetworkConfig
+      liftEitherError (protocolClientError XFTP $ B.unpack $ strEncode srv) (X.getXFTPClient tSess cfg {xftpNetworkConfig} clientDisconnected)
+
+    clientDisconnected :: XFTPClient -> IO ()
+    clientDisconnected client = do
+      atomically $ TM.delete tSess xftpClients
+      incClientStat c userId client "DISCONNECT" ""
+      atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
@@ -429,7 +495,7 @@ getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM
       TM.insert tSess var clients
       pure var
 
-waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar err msg -> m (ProtocolClient err msg)
+waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar msg -> m (Client msg)
 waitForProtocolClient c (_, srv, _) clientVar = do
   NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
   client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
@@ -440,24 +506,24 @@ waitForProtocolClient c (_, srv, _) clientVar = do
 
 newProtocolClient ::
   forall err msg m.
-  (AgentMonad m, ProtocolTypeI (ProtoType msg)) =>
+  (AgentMonad m, ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) =>
   AgentClient ->
   TransportSession msg ->
-  TMap (TransportSession msg) (ClientVar err msg) ->
-  m (ProtocolClient err msg) ->
+  TMap (TransportSession msg) (ClientVar msg) ->
+  m (Client msg) ->
   (AgentClient -> TransportSession msg -> m ()) ->
-  ClientVar err msg ->
-  m (ProtocolClient err msg)
+  ClientVar msg ->
+  m (Client msg)
 newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
   where
-    tryConnectClient :: (ProtocolClient err msg -> m a) -> m () -> m a
+    tryConnectClient :: (Client msg -> m a) -> m () -> m a
     tryConnectClient successAction retryAction =
       tryError connectClient >>= \r -> case r of
         Right client -> do
           logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
           atomically $ putTMVar clientVar r
           liftIO $ incClientStat c userId client "CLIENT" "OK"
-          atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client)
+          atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
           successAction client
         Left e -> do
           liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
@@ -475,10 +541,10 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconne
       withRetryInterval ri $ \_ loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop
       atomically . removeAsyncAction aId $ asyncClients c
 
-hostEvent :: forall err msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient err msg -> ACommand 'Agent
-hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client
+hostEvent :: forall err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
+hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
 
-getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
+getClientConfig :: AgentMonad' m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
 getClientConfig AgentClient {useNetworkConfig} cfgSel = do
   cfg <- asks $ cfgSel . config
   networkConfig <- readTVarIO useNetworkConfig
@@ -489,6 +555,7 @@ closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
   closeProtocolServerClients c smpClients
   closeProtocolServerClients c ntfClients
+  closeProtocolServerClients c xftpClients
   cancelActions . actions $ reconnections c
   cancelActions . actions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
@@ -519,16 +586,24 @@ throwWhenNoDelivery c SndQueue {server, sndId} =
   where
     k = (server, sndId)
 
-closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar err msg)) -> IO ()
+closeProtocolServerClients :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
-  atomically (swapTVar cs M.empty) >>= mapM_ (forkIO . closeClient)
-  where
-    cs = clientsSel c
-    closeClient cVar = do
-      NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
-      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
-        Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
-        _ -> pure ()
+  atomically (clientsSel c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient_ c)
+
+closeClient :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
+closeClient c clientSel tSess =
+  atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
+
+closeClient_ :: ProtocolServerClient err msg => AgentClient -> ClientVar msg -> IO ()
+closeClient_ c cVar = do
+  NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
+  tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+    Just (Right client) -> closeProtocolServerClient client `catchAll_` pure ()
+    _ -> pure ()
+
+closeXFTPServerClient :: AgentMonad' m => AgentClient -> UserId -> RcvFileChunkReplica -> m ()
+closeXFTPServerClient c userId RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId} =
+  mkTransportSession c userId server fId >>= liftIO . closeClient c xftpClients
 
 cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
 cancelActions as = atomically (swapTVar as mempty) >>= mapM_ (forkIO . uninterruptibleCancel)
@@ -542,29 +617,29 @@ withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pur
   where
     newLock = createLock >>= \l -> TM.insert key l locks $> l
 
-withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err msg -> m a) -> m a
+withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a
 withClient_ c tSess@(userId, srv, _) statCmd action = do
   cl <- getProtocolServerClient c tSess
   (action cl <* stat cl "OK") `catchError` logServerError cl
   where
     stat cl = liftIO . incClientStat c userId cl statCmd
-    logServerError :: ProtocolClient err msg -> AgentErrorType -> m a
+    logServerError :: Client msg -> AgentErrorType -> m a
     logServerError cl e = do
       logServer "<--" c srv "" $ strEncode e
       stat cl $ strEncode e
       throwError e
 
-withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err msg -> m a) -> m a
+withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> m a) -> m a
 withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
   logServer "-->" c srv entId cmdStr
   res <- withClient_ c tSess cmdStr action
   logServer "<--" c srv entId "OK"
   return res
 
-withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg, ProtocolTypeI (ProtoType msg), Encoding err, Show err) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err msg -> ExceptT (ProtocolClientError err) IO a) -> m a
+withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
 withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
 
-withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg, ProtocolTypeI (ProtoType msg), Encoding err, Show err) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err msg -> ExceptT (ProtocolClientError err) IO a) -> m a
+withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
 withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
 
 withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
@@ -580,6 +655,17 @@ withSMPClient_ c q cmdStr action = do
 withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> m a
 withNtfClient c srv = withLogClient c (0, srv, Nothing)
 
+withXFTPClient ::
+  (AgentMonad m, ProtocolServerClient err msg) =>
+  AgentClient ->
+  (UserId, ProtoServer msg, EntityId) ->
+  ByteString ->
+  (Client msg -> ExceptT (ProtocolClientError err) IO b) ->
+  m b
+withXFTPClient c (userId, srv, fId) cmdStr action = do
+  tSess <- mkTransportSession c userId srv fId
+  withLogClient c tSess (strEncode fId) cmdStr action
+
 liftClient :: (AgentMonad m, Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> m a
 liftClient protocolError_ = liftError . protocolClientError protocolError_
 
@@ -592,7 +678,7 @@ protocolClientError protocolError_ host = \case
   PCENetworkError -> BROKER host NETWORK
   PCEIncompatibleHost -> BROKER host HOST
   PCETransportError e -> BROKER host $ TRANSPORT e
-  e@PCESignatureError {} -> INTERNAL $ show e
+  e@PCECryptoError {} -> INTERNAL $ show e
   PCEIOError {} -> BROKER host NETWORK
 
 data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
@@ -636,19 +722,19 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
     testErr :: SMPTestStep -> SMPClientError -> SMPTestFailure
     testErr step = SMPTestFailure step . protocolClientError SMP addr
 
-mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
+mkTransportSession :: AgentMonad' m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
 mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c
 
 mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg
 mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing)
 
-mkSMPTransportSession :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession
+mkSMPTransportSession :: (AgentMonad' m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession
 mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c
 
 mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession
 mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 
-getSessionMode :: AgentMonad m => AgentClient -> m TransportSessionMode
+getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode
 getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig
 
 newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri)
@@ -692,13 +778,6 @@ processSubResult c rq r = do
     _ -> addSubscription c rq
   pure r
 
-temporaryClientError :: ProtocolClientError err -> Bool
-temporaryClientError = \case
-  PCENetworkError -> True
-  PCEResponseTimeout -> True
-  PCEIOError _ -> True
-  _ -> False
-
 temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
   BROKER _ NETWORK -> True
@@ -919,6 +998,10 @@ agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -
 agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
 
+agentXFTPDownloadChunk :: AgentMonad m => AgentClient -> UserId -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> m ()
+agentXFTPDownloadChunk c userId RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
+  withXFTPClient c (userId, server, fId) "FGET" $ \xftp -> X.downloadXFTPChunk xftp replicaKey fId chunkSpec
+
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
   cmNonce <- liftIO C.randomCbNonce
@@ -986,7 +1069,7 @@ suspendOperation c op endedAction = do
 notifySuspended :: AgentClient -> STM ()
 notifySuspended c = do
   -- unsafeIOToSTM $ putStrLn "notifySuspended"
-  writeTBQueue (subQ c) ("", "", SUSPENDED)
+  writeTBQueue (subQ c) ("", "", APC SAENone SUSPENDED)
   writeTVar (agentState c) ASSuspended
 
 endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
@@ -1048,7 +1131,7 @@ incStat AgentClient {agentStats} n k = do
     Just v -> modifyTVar' v (+ n)
     _ -> newTVar n >>= \v -> TM.insert k v agentStats
 
-incClientStat :: AgentClient -> UserId -> ProtocolClient err msg -> ByteString -> ByteString -> IO ()
+incClientStat :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO ()
 incClientStat c userId pc = incClientStatN c userId pc 1
 
 incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO ()
@@ -1058,8 +1141,8 @@ incServerStat c userId ProtocolServer {host} cmd res = do
   where
     statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res}
 
-incClientStatN :: AgentClient -> UserId -> ProtocolClient err msg -> Int -> ByteString -> ByteString -> IO ()
+incClientStatN :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> Int -> ByteString -> ByteString -> IO ()
 incClientStatN c userId pc n cmd res = do
   atomically $ incStat c n statsKey
   where
-    statsKey = AgentStatsKey {userId, host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res}
+    statsKey = AgentStatsKey {userId, host = strEncode $ clientTransportHost pc, clientTs = strEncode $ clientSessionTs pc, cmd, res}

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -12,6 +12,7 @@
 
 module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
+    AgentMonad',
     AgentConfig (..),
     AgentDatabase (..),
     databaseFile,
@@ -24,6 +25,7 @@ module Simplex.Messaging.Agent.Env.SQLite
     createAgentStore,
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
+    XFTPAgent (..),
   )
 where
 
@@ -33,13 +35,16 @@ import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
+import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
+import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig)
+import Simplex.FileTransfer.Types (DBSndFileId)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
@@ -47,7 +52,7 @@ import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (NtfServer, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
@@ -57,12 +62,14 @@ import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
 import UnliftIO.STM
 
--- | Agent monad with MonadReader Env and MonadError AgentErrorType
-type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
+type AgentMonad' m = (MonadUnliftIO m, MonadReader Env m)
+
+type AgentMonad m = (AgentMonad' m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty SMPServerWithAuth),
     ntf :: [NtfServer],
+    xftp :: Map UserId (NonEmpty XFTPServerWithAuth),
     netCfg :: NetworkConfig
   }
 
@@ -84,6 +91,7 @@ data AgentConfig = AgentConfig
     yesToMigrations :: Bool,
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
+    xftpCfg :: XFTPClientConfig,
     reconnectInterval :: RetryInterval,
     messageRetryInterval :: RetryInterval2,
     messageTimeout :: NominalDiffTime,
@@ -144,6 +152,7 @@ defaultAgentConfig =
       yesToMigrations = False,
       smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
+      xftpCfg = defaultXFTPClientConfig,
       reconnectInterval = defaultReconnectInterval,
       messageRetryInterval = defaultMessageRetryInterval,
       messageTimeout = 2 * nominalDay,
@@ -173,7 +182,8 @@ data Env = Env
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
     randomServer :: TVar StdGen,
-    ntfSupervisor :: NtfSupervisor
+    ntfSupervisor :: NtfSupervisor,
+    xftpAgent :: XFTPAgent
   }
 
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
@@ -185,7 +195,8 @@ newSMPAgentEnv config@AgentConfig {database, yesToMigrations, initialClientId} =
   clientCounter <- newTVarIO initialClientId
   randomServer <- newTVarIO =<< liftIO newStdGen
   ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
-  return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
+  xftpAgent <- atomically newXFTPAgent
+  return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor, xftpAgent}
 
 createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore
 createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
@@ -207,3 +218,20 @@ newNtfSubSupervisor qSize = do
   ntfWorkers <- TM.empty
   ntfSMPWorkers <- TM.empty
   pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
+
+data XFTPAgent = XFTPAgent
+  { xftpWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
+    -- separate send workers for unhindered concurrency between download and upload,
+    -- clients can also be separate by passing direction to withXFTPClient, and differentiating by it
+    xftpSndWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()),
+    -- files currently in upload - to throttle upload of other files' chunks,
+    -- this optimization can be dropped for the MVP
+    xftpSndFiles :: TVar (Set DBSndFileId)
+  }
+
+newXFTPAgent :: STM XFTPAgent
+newXFTPAgent = do
+  xftpWorkers <- TM.empty
+  xftpSndWorkers <- TM.empty
+  xftpSndFiles <- newTVar S.empty
+  pure XFTPAgent {xftpWorkers, xftpSndWorkers, xftpSndFiles}

src/Simplex/Messaging/Agent/Lock.hs

@@ -14,7 +14,7 @@ createLock :: STM Lock
 createLock = newEmptyTMVar
 {-# INLINE createLock #-}
 
-withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a
+withLock :: MonadUnliftIO m => Lock -> String -> m a -> m a
 withLock lock name =
   E.bracket_
     (atomically $ putTMVar lock name)

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -31,8 +31,7 @@ import Data.Text (Text)
 import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..))
-import qualified Simplex.Messaging.Agent.Protocol as AP
+import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
@@ -40,7 +39,7 @@ import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol
+import Simplex.Messaging.Protocol (NtfServer, ProtocolServer, SMPServer, sameSrvAddr)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (tshow, unlessM)
@@ -50,7 +49,7 @@ import UnliftIO.Concurrent (forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
+runNtfSupervisor :: forall m. AgentMonad' m => AgentClient -> m ()
 runNtfSupervisor c = do
   ns <- asks ntfSupervisor
   forever $ do
@@ -156,7 +155,7 @@ processNtfSub c (connId, cmd) = do
         Just (doWork, _) ->
           void . atomically $ tryPutTMVar doWork ()
 
-withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m ()
+withNtfServer :: AgentMonad' m => AgentClient -> (NtfServer -> m ()) -> m ()
 withNtfServer c action = getNtfServer c >>= mapM_ action
 
 runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m ()
@@ -290,7 +289,7 @@ runNtfSMPWorker c srv doWork = do
             mapM_ (disableQueueNotifications c) rq_
             withStore' c $ \db -> deleteNtfSubscription db connId
 
-rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
+rescheduleAction :: AgentMonad' m => TMVar () -> UTCTime -> UTCTime -> m Bool
 rescheduleAction doWork ts actionTs
   | actionTs <= ts = pure False
   | otherwise = do
@@ -306,7 +305,7 @@ fromPico (MkFixed i) = i
 diffInMicros :: UTCTime -> UTCTime -> Int
 diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
 
-retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
+retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
 retryOnError c name loop done e = do
   logError $ name <> " error: " <> tshow e
   case e of
@@ -325,10 +324,11 @@ workerInternalError c connId internalErrStr = do
   withStore' c $ \db -> setNullNtfSubscriptionAction db connId
   notifyInternalError c connId internalErrStr
 
-notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
-notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
+-- TODO change error
+notifyInternalError :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m ()
+notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr)
 
-getNtfToken :: AgentMonad m => m (Maybe NtfToken)
+getNtfToken :: AgentMonad' m => m (Maybe NtfToken)
 getNtfToken = do
   tkn <- asks $ ntfTkn . ntfSupervisor
   readTVarIO tkn
@@ -359,7 +359,7 @@ cancelNtfWorkers_ wsVar = do
   ws <- atomically $ stateTVar wsVar (,M.empty)
   mapM_ (uninterruptibleCancel . snd) ws
 
-getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
+getNtfServer :: AgentMonad' m => AgentClient -> m (Maybe NtfServer)
 getNtfServer c = do
   ntfServers <- readTVarIO $ ntfServers c
   case ntfServers of

src/Simplex/Messaging/Agent/Protocol.hs

@@ -40,13 +40,19 @@ module Simplex.Messaging.Agent.Protocol
     -- * SMP agent protocol types
     ConnInfo,
     ACommand (..),
+    APartyCmd (..),
     ACommandTag (..),
     aCommandTag,
+    aPartyCmdTag,
     ACmd (..),
+    APartyCmdTag (..),
     ACmdTag (..),
     AParty (..),
+    AEntity (..),
     SAParty (..),
+    SAEntity (..),
     APartyI (..),
+    AEntityI (..),
     MsgHash,
     MsgMeta (..),
     ConnectionStats (..),
@@ -91,11 +97,14 @@ module Simplex.Messaging.Agent.Protocol
     ATransmissionOrError,
     ARawTransmission,
     ConnId,
+    RcvFileId,
+    SndFileId,
     ConfirmationId,
     InvitationId,
     MsgIntegrity (..),
     MsgErrorType (..),
     QueueStatus (..),
+    UserId,
     ACorrId,
     AgentMsgId,
     NotificationsMode (..),
@@ -125,6 +134,8 @@ module Simplex.Messaging.Agent.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Monad (unless)
+import Control.Monad.Except (runExceptT, throwError)
 import Control.Monad.IO.Class
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
@@ -153,6 +164,8 @@ import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType)
 import Simplex.Messaging.Agent.QueryString
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
@@ -161,6 +174,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( AProtocolType,
+    EntityId,
     ErrorType,
     MsgBody,
     MsgFlags,
@@ -207,10 +221,12 @@ e2eEncUserMsgLength = 15856
 type ARawTransmission = (ByteString, ByteString, ByteString)
 
 -- | Parsed SMP agent protocol transmission.
-type ATransmission p = (ACorrId, ConnId, ACommand p)
+type ATransmission p = (ACorrId, EntityId, APartyCmd p)
 
 -- | SMP agent protocol transmission or transmission error.
-type ATransmissionOrError p = (ACorrId, ConnId, Either AgentErrorType (ACommand p))
+type ATransmissionOrError p = (ACorrId, EntityId, Either AgentErrorType (APartyCmd p))
+
+type UserId = Int64
 
 type ACorrId = ByteString
 
@@ -238,96 +254,159 @@ instance APartyI Agent where sAParty = SAgent
 
 instance APartyI Client where sAParty = SClient
 
-data ACmd = forall p. APartyI p => ACmd (SAParty p) (ACommand p)
+data AEntity = AEConn | AERcvFile | AESndFile | AENone
+  deriving (Eq, Show)
+
+data SAEntity :: AEntity -> Type where
+  SAEConn :: SAEntity AEConn
+  SAERcvFile :: SAEntity AERcvFile
+  SAESndFile :: SAEntity AESndFile
+  SAENone :: SAEntity AENone
+
+deriving instance Show (SAEntity e)
+
+deriving instance Eq (SAEntity e)
+
+instance TestEquality SAEntity where
+  testEquality SAEConn SAEConn = Just Refl
+  testEquality SAERcvFile SAERcvFile = Just Refl
+  testEquality SAESndFile SAESndFile = Just Refl
+  testEquality SAENone SAENone = Just Refl
+  testEquality _ _ = Nothing
+
+class AEntityI (e :: AEntity) where sAEntity :: SAEntity e
+
+instance AEntityI AEConn where sAEntity = SAEConn
+
+instance AEntityI AERcvFile where sAEntity = SAERcvFile
+
+instance AEntityI AESndFile where sAEntity = SAESndFile
+
+instance AEntityI AENone where sAEntity = SAENone
+
+data ACmd = forall p e. (APartyI p, AEntityI e) => ACmd (SAParty p) (SAEntity e) (ACommand p e)
 
 deriving instance Show ACmd
 
+data APartyCmd p = forall e. AEntityI e => APC (SAEntity e) (ACommand p e)
+
+instance Eq (APartyCmd p) where
+  APC e cmd == APC e' cmd' = case testEquality e e' of
+    Just Refl -> cmd == cmd'
+    Nothing -> False
+
+deriving instance Show (APartyCmd p)
+
 type ConnInfo = ByteString
 
 -- | Parameterized type for SMP agent protocol commands and responses from all participants.
-data ACommand (p :: AParty) where
-  NEW :: Bool -> AConnectionMode -> ACommand Client -- response INV
-  INV :: AConnectionRequestUri -> ACommand Agent
-  JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
-  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
-  LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
-  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
-  ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
-  RJCT :: InvitationId -> ACommand Client
-  INFO :: ConnInfo -> ACommand Agent
-  CON :: ACommand Agent -- notification that connection is established
-  SUB :: ACommand Client
-  END :: ACommand Agent
-  CONNECT :: AProtocolType -> TransportHost -> ACommand Agent
-  DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent
-  DOWN :: SMPServer -> [ConnId] -> ACommand Agent
-  UP :: SMPServer -> [ConnId] -> ACommand Agent
-  SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent
-  SEND :: MsgFlags -> MsgBody -> ACommand Client
-  MID :: AgentMsgId -> ACommand Agent
-  SENT :: AgentMsgId -> ACommand Agent
-  MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent
-  MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent
-  ACK :: AgentMsgId -> ACommand Client
-  SWCH :: ACommand Client
-  OFF :: ACommand Client
-  DEL :: ACommand Client
-  DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent
-  DEL_CONN :: ACommand Agent
-  DEL_USER :: Int64 -> ACommand Agent
-  CHK :: ACommand Client
-  STAT :: ConnectionStats -> ACommand Agent
-  OK :: ACommand Agent
-  ERR :: AgentErrorType -> ACommand Agent
-  SUSPENDED :: ACommand Agent
+data ACommand (p :: AParty) (e :: AEntity) where
+  NEW :: Bool -> AConnectionMode -> ACommand Client AEConn -- response INV
+  INV :: AConnectionRequestUri -> ACommand Agent AEConn
+  JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client AEConn -- response OK
+  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
+  LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
+  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
+  ACPT :: InvitationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
+  RJCT :: InvitationId -> ACommand Client AEConn
+  INFO :: ConnInfo -> ACommand Agent AEConn
+  CON :: ACommand Agent AEConn -- notification that connection is established
+  SUB :: ACommand Client AEConn
+  END :: ACommand Agent AEConn
+  CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
+  DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
+  DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone
+  UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
+  SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
+  SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
+  MID :: AgentMsgId -> ACommand Agent AEConn
+  SENT :: AgentMsgId -> ACommand Agent AEConn
+  MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
+  MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn
+  ACK :: AgentMsgId -> ACommand Client AEConn
+  SWCH :: ACommand Client AEConn
+  OFF :: ACommand Client AEConn
+  DEL :: ACommand Client AEConn
+  DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent AEConn
+  DEL_CONN :: ACommand Agent AEConn
+  DEL_USER :: Int64 -> ACommand Agent AENone
+  CHK :: ACommand Client AEConn
+  STAT :: ConnectionStats -> ACommand Agent AEConn
+  OK :: ACommand Agent AEConn
+  ERR :: AgentErrorType -> ACommand Agent AEConn
+  SUSPENDED :: ACommand Agent AENone
+  -- XFTP commands and responses
+  RFPROG :: Int -> Int -> ACommand Agent AERcvFile
+  RFDONE :: FilePath -> ACommand Agent AERcvFile
+  RFERR :: AgentErrorType -> ACommand Agent AERcvFile
+  SFPROG :: Int -> Int -> ACommand Agent AESndFile
+  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile
 
-deriving instance Eq (ACommand p)
+deriving instance Eq (ACommand p e)
 
-deriving instance Show (ACommand p)
+deriving instance Show (ACommand p e)
 
-data ACmdTag = forall p. APartyI p => ACmdTag (SAParty p) (ACommandTag p)
+data ACmdTag = forall p e. (APartyI p, AEntityI e) => ACmdTag (SAParty p) (SAEntity e) (ACommandTag p e)
 
-data ACommandTag (p :: AParty) where
-  NEW_ :: ACommandTag Client
-  INV_ :: ACommandTag Agent
-  JOIN_ :: ACommandTag Client
-  CONF_ :: ACommandTag Agent
-  LET_ :: ACommandTag Client
-  REQ_ :: ACommandTag Agent
-  ACPT_ :: ACommandTag Client
-  RJCT_ :: ACommandTag Client
-  INFO_ :: ACommandTag Agent
-  CON_ :: ACommandTag Agent
-  SUB_ :: ACommandTag Client
-  END_ :: ACommandTag Agent
-  CONNECT_ :: ACommandTag Agent
-  DISCONNECT_ :: ACommandTag Agent
-  DOWN_ :: ACommandTag Agent
-  UP_ :: ACommandTag Agent
-  SWITCH_ :: ACommandTag Agent
-  SEND_ :: ACommandTag Client
-  MID_ :: ACommandTag Agent
-  SENT_ :: ACommandTag Agent
-  MERR_ :: ACommandTag Agent
-  MSG_ :: ACommandTag Agent
-  ACK_ :: ACommandTag Client
-  SWCH_ :: ACommandTag Client
-  OFF_ :: ACommandTag Client
-  DEL_ :: ACommandTag Client
-  DEL_RCVQ_ :: ACommandTag Agent
-  DEL_CONN_ :: ACommandTag Agent
-  DEL_USER_ :: ACommandTag Agent
-  CHK_ :: ACommandTag Client
-  STAT_ :: ACommandTag Agent
-  OK_ :: ACommandTag Agent
-  ERR_ :: ACommandTag Agent
-  SUSPENDED_ :: ACommandTag Agent
+data APartyCmdTag p = forall e. AEntityI e => APCT (SAEntity e) (ACommandTag p e)
 
-deriving instance Eq (ACommandTag p)
+instance Eq (APartyCmdTag p) where
+  APCT e cmd == APCT e' cmd' = case testEquality e e' of
+    Just Refl -> cmd == cmd'
+    Nothing -> False
 
-deriving instance Show (ACommandTag p)
+deriving instance Show (APartyCmdTag p)
 
-aCommandTag :: ACommand p -> ACommandTag p
+data ACommandTag (p :: AParty) (e :: AEntity) where
+  NEW_ :: ACommandTag Client AEConn
+  INV_ :: ACommandTag Agent AEConn
+  JOIN_ :: ACommandTag Client AEConn
+  CONF_ :: ACommandTag Agent AEConn
+  LET_ :: ACommandTag Client AEConn
+  REQ_ :: ACommandTag Agent AEConn
+  ACPT_ :: ACommandTag Client AEConn
+  RJCT_ :: ACommandTag Client AEConn
+  INFO_ :: ACommandTag Agent AEConn
+  CON_ :: ACommandTag Agent AEConn
+  SUB_ :: ACommandTag Client AEConn
+  END_ :: ACommandTag Agent AEConn
+  CONNECT_ :: ACommandTag Agent AENone
+  DISCONNECT_ :: ACommandTag Agent AENone
+  DOWN_ :: ACommandTag Agent AENone
+  UP_ :: ACommandTag Agent AENone
+  SWITCH_ :: ACommandTag Agent AEConn
+  SEND_ :: ACommandTag Client AEConn
+  MID_ :: ACommandTag Agent AEConn
+  SENT_ :: ACommandTag Agent AEConn
+  MERR_ :: ACommandTag Agent AEConn
+  MSG_ :: ACommandTag Agent AEConn
+  ACK_ :: ACommandTag Client AEConn
+  SWCH_ :: ACommandTag Client AEConn
+  OFF_ :: ACommandTag Client AEConn
+  DEL_ :: ACommandTag Client AEConn
+  DEL_RCVQ_ :: ACommandTag Agent AEConn
+  DEL_CONN_ :: ACommandTag Agent AEConn
+  DEL_USER_ :: ACommandTag Agent AENone
+  CHK_ :: ACommandTag Client AEConn
+  STAT_ :: ACommandTag Agent AEConn
+  OK_ :: ACommandTag Agent AEConn
+  ERR_ :: ACommandTag Agent AEConn
+  SUSPENDED_ :: ACommandTag Agent AENone
+  -- XFTP commands and responses
+  RFDONE_ :: ACommandTag Agent AERcvFile
+  RFPROG_ :: ACommandTag Agent AERcvFile
+  RFERR_ :: ACommandTag Agent AERcvFile
+  SFPROG_ :: ACommandTag Agent AESndFile
+  SFDONE_ :: ACommandTag Agent AESndFile
+
+deriving instance Eq (ACommandTag p e)
+
+deriving instance Show (ACommandTag p e)
+
+aPartyCmdTag :: APartyCmd p -> APartyCmdTag p
+aPartyCmdTag (APC e cmd) = APCT e $ aCommandTag cmd
+
+aCommandTag :: ACommand p e -> ACommandTag p e
 aCommandTag = \case
   NEW {} -> NEW_
   INV _ -> INV_
@@ -363,6 +442,11 @@ aCommandTag = \case
   OK -> OK_
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
+  RFPROG {} -> RFPROG_
+  RFDONE {} -> RFDONE_
+  RFERR {} -> RFERR_
+  SFPROG {} -> SFPROG_
+  SFDONE {} -> SFDONE_
 
 data QueueDirection = QDRcv | QDSnd
   deriving (Eq, Show)
@@ -811,6 +895,10 @@ connModeT = \case
 -- | SMP agent connection ID.
 type ConnId = ByteString
 
+type RcvFileId = ByteString
+
+type SndFileId = ByteString
+
 type ConfirmationId = ByteString
 
 type InvitationId = ByteString
@@ -1070,6 +1158,8 @@ data AgentErrorType
     SMP {smpErr :: ErrorType}
   | -- | NTF protocol errors forwarded to agent clients
     NTF {ntfErr :: ErrorType}
+  | -- | XFTP protocol errors forwarded to agent clients
+    XFTP {xftpErr :: XFTPErrorType}
   | -- | SMP server errors
     BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
   | -- | errors of other agents
@@ -1164,6 +1254,7 @@ instance StrEncoding AgentErrorType where
       <|> "CONN " *> (CONN <$> parseRead1)
       <|> "SMP " *> (SMP <$> strP)
       <|> "NTF " *> (NTF <$> strP)
+      <|> "XFTP " *> (XFTP <$> strP)
       <|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
       <|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
       <|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
@@ -1177,6 +1268,7 @@ instance StrEncoding AgentErrorType where
     CONN e -> "CONN " <> bshow e
     SMP e -> "SMP " <> strEncode e
     NTF e -> "NTF " <> strEncode e
+    XFTP e -> "XFTP " <> strEncode e
     BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e
     BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e
     BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e
@@ -1205,46 +1297,60 @@ dbCommandP :: Parser ACmd
 dbCommandP = commandP $ A.take =<< (A.decimal <* "\n")
 
 instance StrEncoding ACmdTag where
-  strEncode (ACmdTag _ cmd) = strEncode cmd
+  strEncode (ACmdTag _ _ cmd) = strEncode cmd
   strP =
     A.takeTill (== ' ') >>= \case
-      "NEW" -> pure $ ACmdTag SClient NEW_
-      "INV" -> pure $ ACmdTag SAgent INV_
-      "JOIN" -> pure $ ACmdTag SClient JOIN_
-      "CONF" -> pure $ ACmdTag SAgent CONF_
-      "LET" -> pure $ ACmdTag SClient LET_
-      "REQ" -> pure $ ACmdTag SAgent REQ_
-      "ACPT" -> pure $ ACmdTag SClient ACPT_
-      "RJCT" -> pure $ ACmdTag SClient RJCT_
-      "INFO" -> pure $ ACmdTag SAgent INFO_
-      "CON" -> pure $ ACmdTag SAgent CON_
-      "SUB" -> pure $ ACmdTag SClient SUB_
-      "END" -> pure $ ACmdTag SAgent END_
-      "CONNECT" -> pure $ ACmdTag SAgent CONNECT_
-      "DISCONNECT" -> pure $ ACmdTag SAgent DISCONNECT_
-      "DOWN" -> pure $ ACmdTag SAgent DOWN_
-      "UP" -> pure $ ACmdTag SAgent UP_
-      "SWITCH" -> pure $ ACmdTag SAgent SWITCH_
-      "SEND" -> pure $ ACmdTag SClient SEND_
-      "MID" -> pure $ ACmdTag SAgent MID_
-      "SENT" -> pure $ ACmdTag SAgent SENT_
-      "MERR" -> pure $ ACmdTag SAgent MERR_
-      "MSG" -> pure $ ACmdTag SAgent MSG_
-      "ACK" -> pure $ ACmdTag SClient ACK_
-      "SWCH" -> pure $ ACmdTag SClient SWCH_
-      "OFF" -> pure $ ACmdTag SClient OFF_
-      "DEL" -> pure $ ACmdTag SClient DEL_
-      "DEL_RCVQ" -> pure $ ACmdTag SAgent DEL_RCVQ_
-      "DEL_CONN" -> pure $ ACmdTag SAgent DEL_CONN_
-      "DEL_USER" -> pure $ ACmdTag SAgent DEL_USER_
-      "CHK" -> pure $ ACmdTag SClient CHK_
-      "STAT" -> pure $ ACmdTag SAgent STAT_
-      "OK" -> pure $ ACmdTag SAgent OK_
-      "ERR" -> pure $ ACmdTag SAgent ERR_
-      "SUSPENDED" -> pure $ ACmdTag SAgent SUSPENDED_
+      "NEW" -> t NEW_
+      "INV" -> ct INV_
+      "JOIN" -> t JOIN_
+      "CONF" -> ct CONF_
+      "LET" -> t LET_
+      "REQ" -> ct REQ_
+      "ACPT" -> t ACPT_
+      "RJCT" -> t RJCT_
+      "INFO" -> ct INFO_
+      "CON" -> ct CON_
+      "SUB" -> t SUB_
+      "END" -> ct END_
+      "CONNECT" -> nt CONNECT_
+      "DISCONNECT" -> nt DISCONNECT_
+      "DOWN" -> nt DOWN_
+      "UP" -> nt UP_
+      "SWITCH" -> ct SWITCH_
+      "SEND" -> t SEND_
+      "MID" -> ct MID_
+      "SENT" -> ct SENT_
+      "MERR" -> ct MERR_
+      "MSG" -> ct MSG_
+      "ACK" -> t ACK_
+      "SWCH" -> t SWCH_
+      "OFF" -> t OFF_
+      "DEL" -> t DEL_
+      "DEL_RCVQ" -> ct DEL_RCVQ_
+      "DEL_CONN" -> ct DEL_CONN_
+      "DEL_USER" -> nt DEL_USER_
+      "CHK" -> t CHK_
+      "STAT" -> ct STAT_
+      "OK" -> ct OK_
+      "ERR" -> ct ERR_
+      "SUSPENDED" -> nt SUSPENDED_
+      "RFPROG" -> at SAERcvFile RFPROG_
+      "RFDONE" -> at SAERcvFile RFDONE_
+      "RFERR" -> at SAERcvFile RFERR_
+      "SFPROG" -> at SAESndFile SFPROG_
+      "SFDONE" -> at SAESndFile SFDONE_
       _ -> fail "bad ACmdTag"
+    where
+      t = pure . ACmdTag SClient SAEConn
+      at e = pure . ACmdTag SAgent e
+      ct = at SAEConn
+      nt = at SAENone
 
-instance APartyI p => StrEncoding (ACommandTag p) where
+instance APartyI p => StrEncoding (APartyCmdTag p) where
+  strEncode (APCT _ cmd) = strEncode cmd
+  strP = (\(ACmdTag _ e t) -> checkParty $ APCT e t) <$?> strP
+
+instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
   strEncode = \case
     NEW_ -> "NEW"
     INV_ -> "INV"
@@ -1280,20 +1386,30 @@ instance APartyI p => StrEncoding (ACommandTag p) where
     OK_ -> "OK"
     ERR_ -> "ERR"
     SUSPENDED_ -> "SUSPENDED"
-  strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP
+    RFPROG_ -> "RFPROG"
+    RFDONE_ -> "RFDONE"
+    RFERR_ -> "RFERR"
+    SFPROG_ -> "SFPROG"
+    SFDONE_ -> "SFDONE"
+  strP = (\(APCT _ t) -> checkEntity t) <$?> strP
 
 checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p)
 checkParty x = case testEquality (sAParty @p) (sAParty @p') of
   Just Refl -> Right x
   Nothing -> Left "bad party"
 
+checkEntity :: forall t e e'. (AEntityI e, AEntityI e') => t e' -> Either String (t e)
+checkEntity x = case testEquality (sAEntity @e) (sAEntity @e') of
+  Just Refl -> Right x
+  Nothing -> Left "bad entity"
+
 -- | SMP agent command and response parser
 commandP :: Parser ByteString -> Parser ACmd
 commandP binaryP =
   strP
     >>= \case
-      ACmdTag SClient cmd ->
-        ACmd SClient <$> case cmd of
+      ACmdTag SClient e cmd ->
+        ACmd SClient e <$> case cmd of
           NEW_ -> s (NEW <$> strP_ <*> strP)
           JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> binaryP)
           LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
@@ -1306,8 +1422,8 @@ commandP binaryP =
           OFF_ -> pure OFF
           DEL_ -> pure DEL
           CHK_ -> pure CHK
-      ACmdTag SAgent cmd ->
-        ACmd SAgent <$> case cmd of
+      ACmdTag SAgent e cmd ->
+        ACmd SAgent e <$> case cmd of
           INV_ -> s (INV <$> strP)
           CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP)
           REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP)
@@ -1330,11 +1446,22 @@ commandP binaryP =
           OK_ -> pure OK
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
+          RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
+          RFDONE_ -> s (RFDONE <$> strP)
+          RFERR_ -> s (RFERR <$> strP)
+          SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal)
+          SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
     connections :: Parser [ConnId]
     connections = strP `A.sepBy'` A.char ','
+    sfDone :: Text -> Either String (ACommand 'Agent 'AESndFile)
+    sfDone t =
+      let ds = T.splitOn fdSeparator t
+       in case ds of
+            [] -> Left "no sender file description"
+            sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds
     msgMetaP = do
       integrity <- strP
       recipient <- " R=" *> partyMeta A.decimal
@@ -1347,7 +1474,7 @@ parseCommand :: ByteString -> Either AgentErrorType ACmd
 parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
 
 -- | Serialize SMP agent command.
-serializeCommand :: ACommand p -> ByteString
+serializeCommand :: ACommand p e -> ByteString
 serializeCommand = \case
   NEW ntfs cMode -> s (NEW_, ntfs, cMode)
   INV cReq -> s (INV_, cReq)
@@ -1383,6 +1510,11 @@ serializeCommand = \case
   ERR e -> s (ERR_, e)
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
+  RFPROG rcvd total -> s (RFPROG_, rcvd, total)
+  RFDONE fPath -> s (RFDONE_, fPath)
+  RFERR e -> s (RFERR_, e)
+  SFPROG sent total -> s (SFPROG_, sent, total)
+  SFDONE sd rds -> B.unwords [s SFDONE_, serializeBinary (sfDone sd rds)]
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
@@ -1390,6 +1522,7 @@ serializeCommand = \case
     showTs = B.pack . formatISO8601Millis
     connections :: [ConnId] -> ByteString
     connections = B.intercalate "," . map strEncode
+    sfDone sd rds = B.intercalate fdSeparator $ strEncode sd : map strEncode rds
     serializeMsgMeta :: MsgMeta -> ByteString
     serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
       B.unwords
@@ -1415,60 +1548,65 @@ tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h
 
 -- | Send SMP agent protocol command (or response) to TCP connection.
 tPut :: (Transport c, MonadIO m) => c -> ATransmission p -> m ()
-tPut h (corrId, connId, command) =
-  liftIO $ tPutRaw h (corrId, connId, serializeCommand command)
+tPut h (corrId, connId, APC _ cmd) =
+  liftIO $ tPutRaw h (corrId, connId, serializeCommand cmd)
 
 -- | Receive client and agent transmissions from TCP connection.
 tGet :: forall c m p. (Transport c, MonadIO m) => SAParty p -> c -> m (ATransmissionOrError p)
 tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
   where
     tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p)
-    tParseLoadBody t@(corrId, connId, command) = do
+    tParseLoadBody t@(corrId, entId, command) = do
       let cmd = parseCommand command >>= fromParty >>= tConnId t
       fullCmd <- either (return . Left) cmdWithMsgBody cmd
-      return (corrId, connId, fullCmd)
+      return (corrId, entId, fullCmd)
 
-    fromParty :: ACmd -> Either AgentErrorType (ACommand p)
-    fromParty (ACmd (p :: p1) cmd) = case testEquality party p of
-      Just Refl -> Right cmd
+    fromParty :: ACmd -> Either AgentErrorType (APartyCmd p)
+    fromParty (ACmd (p :: p1) e cmd) = case testEquality party p of
+      Just Refl -> Right $ APC e cmd
       _ -> Left $ CMD PROHIBITED
 
-    tConnId :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p)
-    tConnId (_, connId, _) cmd = case cmd of
-      -- NEW, JOIN and ACPT have optional connId
-      NEW {} -> Right cmd
-      JOIN {} -> Right cmd
-      ACPT {} -> Right cmd
-      -- ERROR response does not always have connId
-      ERR _ -> Right cmd
-      CONNECT {} -> Right cmd
-      DISCONNECT {} -> Right cmd
-      DOWN {} -> Right cmd
-      UP {} -> Right cmd
-      -- other responses must have connId
-      _
-        | B.null connId -> Left $ CMD NO_CONN
-        | otherwise -> Right cmd
+    tConnId :: ARawTransmission -> APartyCmd p -> Either AgentErrorType (APartyCmd p)
+    tConnId (_, entId, _) (APC e cmd) =
+      APC e <$> case cmd of
+        -- NEW, JOIN and ACPT have optional connection ID
+        NEW {} -> Right cmd
+        JOIN {} -> Right cmd
+        ACPT {} -> Right cmd
+        -- ERROR response does not always have connection ID
+        ERR _ -> Right cmd
+        CONNECT {} -> Right cmd
+        DISCONNECT {} -> Right cmd
+        DOWN {} -> Right cmd
+        UP {} -> Right cmd
+        SUSPENDED {} -> Right cmd
+        -- other responses must have connection ID
+        _
+          | B.null entId -> Left $ CMD NO_CONN
+          | otherwise -> Right cmd
 
-    cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p))
-    cmdWithMsgBody = \case
-      SEND msgFlags body -> SEND msgFlags <$$> getBody body
-      MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
-      JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo
-      CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
-      LET confId cInfo -> LET confId <$$> getBody cInfo
-      REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
-      ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
-      INFO cInfo -> INFO <$$> getBody cInfo
-      cmd -> pure $ Right cmd
+    cmdWithMsgBody :: APartyCmd p -> m (Either AgentErrorType (APartyCmd p))
+    cmdWithMsgBody (APC e cmd) =
+      APC e <$$> case cmd of
+        SEND msgFlags body -> SEND msgFlags <$$> getBody body
+        MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
+        JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo
+        CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
+        LET confId cInfo -> LET confId <$$> getBody cInfo
+        REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
+        ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
+        INFO cInfo -> INFO <$$> getBody cInfo
+        _ -> pure $ Right cmd
 
     getBody :: ByteString -> m (Either AgentErrorType ByteString)
     getBody binary =
       case B.unpack binary of
         ':' : body -> return . Right $ B.pack body
         str -> case readMaybe str :: Maybe Int of
-          Just size -> liftIO $ do
-            body <- cGet h size
-            s <- getLn h
-            return $ if B.null s then Right body else Left $ CMD SIZE
+          Just size -> runExceptT $ do
+            body <- liftIO $ cGet h size
+            unless (B.length body == size) $ throwError $ CMD SIZE
+            s <- liftIO $ getLn h
+            unless (B.null s) $ throwError $ CMD SIZE
+            pure body
           Nothing -> return . Left $ CMD SYNTAX

src/Simplex/Messaging/Agent/Server.hs

@@ -60,10 +60,10 @@ connectClient h c = race_ (send h c) (receive h c)
 
 receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
 receive h c@AgentClient {rcvQ, subQ} = forever $ do
-  (corrId, connId, cmdOrErr) <- tGet SClient h
+  (corrId, entId, cmdOrErr) <- tGet SClient h
   case cmdOrErr of
-    Right cmd -> write rcvQ (corrId, connId, cmd)
-    Left e -> write subQ (corrId, connId, ERR e)
+    Right cmd -> write rcvQ (corrId, entId, cmd)
+    Left e -> write subQ (corrId, entId, APC SAEConn $ ERR e)
   where
     write :: TBQueue (ATransmission p) -> ATransmission p -> m ()
     write q t = do
@@ -77,5 +77,5 @@ send h c@AgentClient {subQ} = forever $ do
   logClient c "<--" t
 
 logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
-logClient AgentClient {clientId} dir (corrId, connId, cmd) = do
+logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do
   logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd]

src/Simplex/Messaging/Agent/Store.hs

@@ -264,8 +264,6 @@ data PendingCommand = PendingCommand
 
 data AgentCmdType = ACClient | ACInternal
 
-type UserId = Int64
-
 instance StrEncoding AgentCmdType where
   strEncode = \case
     ACClient -> "CLIENT"
@@ -277,20 +275,20 @@ instance StrEncoding AgentCmdType where
       _ -> fail "bad AgentCmdType"
 
 data AgentCommand
-  = AClientCommand (ACommand 'Client)
+  = AClientCommand (APartyCmd 'Client)
   | AInternalCommand InternalCommand
 
 instance StrEncoding AgentCommand where
   strEncode = \case
-    AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
+    AClientCommand (APC _ cmd) -> strEncode (ACClient, Str $ serializeCommand cmd)
     AInternalCommand cmd -> strEncode (ACInternal, cmd)
   strP =
     strP_ >>= \case
-      ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP)
+      ACClient -> AClientCommand <$> ((\(ACmd _ e cmd) -> checkParty $ APC e cmd) <$?> dbCommandP)
       ACInternal -> AInternalCommand <$> strP
 
 data AgentCommandTag
-  = AClientCommandTag (ACommandTag 'Client)
+  = AClientCommandTag (APartyCmdTag 'Client)
   | AInternalCommandTag InternalCommandTag
   deriving (Show)
 
@@ -363,7 +361,7 @@ instance StrEncoding InternalCommandTag where
 
 agentCommandTag :: AgentCommand -> AgentCommandTag
 agentCommandTag = \case
-  AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
+  AClientCommand cmd -> AClientCommandTag $ aPartyCmdTag cmd
   AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
 
 internalCmdTag :: InternalCommand -> InternalCommandTag
@@ -535,4 +533,8 @@ data StoreError
     SEX3dhKeysNotFound
   | -- | Used to wrap agent errors inside store operations to avoid race conditions
     SEAgentError AgentErrorType
+  | -- | XFTP Server not found.
+    SEXFTPServerNotFound
+  | -- | XFTP File not found.
+    SEFileNotFound
   deriving (Eq, Show, Exception)

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -123,6 +123,23 @@ module Simplex.Messaging.Agent.Store.SQLite
     getActiveNtfToken,
     getNtfRcvQueue,
     setConnectionNtfs,
+    -- File transfer
+    createRcvFile,
+    getRcvFile,
+    getRcvFileByEntityId,
+    updateRcvChunkReplicaDelay,
+    updateRcvFileChunkReceived,
+    updateRcvFileStatus,
+    updateRcvFileError,
+    updateRcvFileComplete,
+    updateRcvFileNoTmpPath,
+    updateRcvFileDeleted,
+    deleteRcvFile',
+    getNextRcvChunkToDownload,
+    getNextRcvFileToDecrypt,
+    getPendingRcvFilesServers,
+    getCleanupRcvFilesTmpPaths,
+    getCleanupRcvFilesDeleted,
 
     -- * utilities
     withConnection,
@@ -155,6 +172,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Word (Word32)
 import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..))
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.FromField
@@ -162,6 +180,9 @@ import Database.SQLite.Simple.QQ (sql)
 import Database.SQLite.Simple.ToField (ToField (..))
 import qualified Database.SQLite3 as SQLite3
 import Network.Socket (ServiceName)
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Types
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration)
@@ -173,7 +194,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
-import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, SndPublicVerifyKey, pattern NtfServer)
+import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>))
@@ -1703,3 +1724,257 @@ randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerat
 ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction)
 ntfSubAndSMPAction (NtfSubNTFAction action) = (Just action, Nothing)
 ntfSubAndSMPAction (NtfSubSMPAction action) = (Nothing, Just action)
+
+createXFTPServer_ :: DB.Connection -> XFTPServer -> IO Int64
+createXFTPServer_ db newSrv@ProtocolServer {host, port, keyHash} =
+  getXFTPServerId_ db newSrv >>= \case
+    Right srvId -> pure srvId
+    Left _ -> insertNewServer_
+  where
+    insertNewServer_ = do
+      DB.execute db "INSERT INTO xftp_servers (xftp_host, xftp_port, xftp_key_hash) VALUES (?,?,?)" (host, port, keyHash)
+      insertedRowId db
+
+getXFTPServerId_ :: DB.Connection -> XFTPServer -> IO (Either StoreError Int64)
+getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do
+  firstRow fromOnly SEXFTPServerNotFound $
+    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 -> FilePath -> IO (Either StoreError RcvFileId)
+createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath savePath = runExceptT $ do
+  (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd
+  liftIO $
+    forM_ chunks $ \fc@FileChunk {replicas} -> do
+      chunkId <- insertChunk fc rcvFileId
+      forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertReplica rno replica chunkId
+  pure rcvFileEntityId
+  where
+    insertRcvFile :: FileDescription 'FRecipient -> IO (Either StoreError (RcvFileId, DBRcvFileId))
+    insertRcvFile FileDescription {size, digest, key, nonce, chunkSize} = runExceptT $ do
+      rcvFileEntityId <- ExceptT $
+        createWithRandomId gVar $ \rcvFileEntityId ->
+          DB.execute
+            db
+            "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, status) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
+            ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize) :. (prefixPath, tmpPath, savePath, RFSReceiving))
+      rcvFileId <- liftIO $ insertedRowId db
+      pure (rcvFileEntityId, rcvFileId)
+    insertChunk :: FileChunk -> DBRcvFileId -> IO Int64
+    insertChunk FileChunk {chunkNo, chunkSize, digest} rcvFileId = do
+      DB.execute
+        db
+        "INSERT INTO rcv_file_chunks (rcv_file_id, chunk_no, chunk_size, digest) VALUES (?,?,?,?)"
+        (rcvFileId, chunkNo, chunkSize, digest)
+      insertedRowId db
+    insertReplica :: Int -> FileChunkReplica -> Int64 -> IO ()
+    insertReplica replicaNo FileChunkReplica {server, replicaId, replicaKey} chunkId = do
+      srvId <- createXFTPServer_ db server
+      DB.execute
+        db
+        "INSERT INTO rcv_file_chunk_replicas (replica_number, rcv_file_chunk_id, xftp_server_id, replica_id, replica_key) VALUES (?,?,?,?,?)"
+        (replicaNo, chunkId, srvId, replicaId, replicaKey)
+
+getRcvFileByEntityId :: DB.Connection -> UserId -> RcvFileId -> IO (Either StoreError RcvFile)
+getRcvFileByEntityId db userId rcvFileEntityId = runExceptT $ do
+  rcvFileId <- ExceptT $ getRcvFileIdByEntityId_ db userId rcvFileEntityId
+  ExceptT $ getRcvFile db rcvFileId
+
+getRcvFileIdByEntityId_ :: DB.Connection -> UserId -> RcvFileId -> IO (Either StoreError DBRcvFileId)
+getRcvFileIdByEntityId_ db userId rcvFileEntityId =
+  firstRow fromOnly SEFileNotFound $
+    DB.query db "SELECT rcv_file_id FROM rcv_files WHERE user_id = ? AND rcv_file_entity_id = ?" (userId, rcvFileEntityId)
+
+getRcvFile :: DB.Connection -> DBRcvFileId -> IO (Either StoreError RcvFile)
+getRcvFile db rcvFileId = runExceptT $ do
+  fd@RcvFile {rcvFileEntityId, userId, tmpPath} <- ExceptT getFile
+  chunks <- maybe (pure []) (liftIO . getChunks rcvFileEntityId userId) tmpPath
+  pure (fd {chunks} :: RcvFile)
+  where
+    getFile :: IO (Either StoreError RcvFile)
+    getFile = do
+      firstRow toFile SEFileNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, status, deleted
+            FROM rcv_files
+            WHERE rcv_file_id = ?
+          |]
+          (Only rcvFileId)
+      where
+        toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath, FilePath, RcvFileStatus, Bool) -> RcvFile
+        toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, savePath, status, deleted) =
+          RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, savePath, status, deleted, chunks = []}
+    getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk]
+    getChunks rcvFileEntityId userId fileTmpPath = do
+      chunks <-
+        map toChunk
+          <$> DB.query
+            db
+            [sql|
+              SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path
+              FROM rcv_file_chunks
+              WHERE rcv_file_id = ?
+            |]
+            (Only rcvFileId)
+      forM chunks $ \chunk@RcvFileChunk {rcvChunkId} -> do
+        replicas' <- getChunkReplicas rcvChunkId
+        pure (chunk {replicas = replicas'} :: RcvFileChunk)
+      where
+        toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath) -> RcvFileChunk
+        toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath) =
+          RcvFileChunk {rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, replicas = []}
+    getChunkReplicas :: Int64 -> IO [RcvFileChunkReplica]
+    getChunkReplicas chunkId = do
+      map toReplica
+        <$> DB.query
+          db
+          [sql|
+            SELECT
+              r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries,
+              s.xftp_host, s.xftp_port, s.xftp_key_hash
+            FROM rcv_file_chunk_replicas r
+            JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+            WHERE r.rcv_file_chunk_id = ?
+          |]
+          (Only chunkId)
+      where
+        toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
+        toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) =
+          let server = XFTPServer host port keyHash
+           in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}
+
+updateRcvChunkReplicaDelay :: DB.Connection -> Int64 -> Int -> IO ()
+updateRcvChunkReplicaDelay db replicaId delay = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (delay, updatedAt, replicaId)
+
+updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> DBRcvFileId -> FilePath -> IO (Either StoreError RcvFile)
+updateRcvFileChunkReceived db rId cId fId chunkTmpPath = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_file_chunk_replicas SET received = 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, rId)
+  DB.execute db "UPDATE rcv_file_chunks SET tmp_path = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (chunkTmpPath, updatedAt, cId)
+  getRcvFile db fId
+
+updateRcvFileStatus :: DB.Connection -> DBRcvFileId -> RcvFileStatus -> IO ()
+updateRcvFileStatus db rcvFileId status = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_files SET status = ?, updated_at = ? WHERE rcv_file_id = ?" (status, updatedAt, rcvFileId)
+
+updateRcvFileError :: DB.Connection -> DBRcvFileId -> String -> IO ()
+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 -> IO ()
+updateRcvFileComplete db rcvFileId = do
+  updatedAt <- getCurrentTime
+  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
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_files SET tmp_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId)
+
+updateRcvFileDeleted :: DB.Connection -> DBRcvFileId -> IO ()
+updateRcvFileDeleted db rcvFileId = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_files SET deleted = 1, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId)
+
+deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO ()
+deleteRcvFile' db rcvFileId =
+  DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId)
+
+getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> IO (Maybe RcvFileChunk)
+getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
+  maybeFirstRow toChunk $
+    DB.query
+      db
+      [sql|
+        SELECT
+          f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
+          r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries
+        FROM rcv_file_chunk_replicas r
+        JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+        JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
+        JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id
+        WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
+          AND r.received = 0 AND r.replica_number = 1
+          AND f.status = ? AND f.deleted = 0
+        ORDER BY r.created_at ASC
+        LIMIT 1
+      |]
+      (host, port, keyHash, RFSReceiving)
+  where
+    toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int, Int)) -> RcvFileChunk
+    toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) =
+      RcvFileChunk
+        { rcvFileId,
+          rcvFileEntityId,
+          userId,
+          rcvChunkId,
+          chunkNo,
+          chunkSize,
+          digest,
+          fileTmpPath,
+          chunkTmpPath,
+          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
+        }
+
+getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
+getNextRcvFileToDecrypt db = do
+  fileId_ :: Maybe DBRcvFileId <-
+    maybeFirstRow fromOnly $
+      DB.query
+        db
+        [sql|
+          SELECT rcv_file_id
+          FROM rcv_files
+          WHERE status IN (?,?) AND deleted = 0
+          ORDER BY created_at ASC LIMIT 1
+        |]
+        (RFSReceived, RFSDecrypting)
+  case fileId_ of
+    Nothing -> pure Nothing
+    Just fileId -> eitherToMaybe <$> getRcvFile db fileId
+
+getPendingRcvFilesServers :: DB.Connection -> IO [XFTPServer]
+getPendingRcvFilesServers db = do
+  map toServer
+    <$> DB.query
+      db
+      [sql|
+        SELECT DISTINCT
+          s.xftp_host, s.xftp_port, s.xftp_key_hash
+        FROM rcv_file_chunk_replicas r
+        JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+        JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
+        JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id
+        WHERE r.received = 0 AND r.replica_number = 1
+          AND f.status = ? AND f.deleted = 0
+      |]
+      (Only RFSReceiving)
+  where
+    toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
+    toServer (host, port, keyHash) = XFTPServer host port keyHash
+
+getCleanupRcvFilesTmpPaths :: DB.Connection -> IO [(DBRcvFileId, FilePath)]
+getCleanupRcvFilesTmpPaths db =
+  DB.query
+    db
+    [sql|
+      SELECT rcv_file_id, tmp_path
+      FROM rcv_files
+      WHERE status IN (?,?) AND tmp_path IS NOT NULL
+    |]
+    (RFSComplete, RFSError)
+
+getCleanupRcvFilesDeleted :: DB.Connection -> IO [(DBRcvFileId, FilePath)]
+getCleanupRcvFilesDeleted db =
+  DB.query_
+    db
+    [sql|
+      SELECT rcv_file_id, prefix_path
+      FROM rcv_files
+      WHERE deleted = 1
+    |]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs

@@ -41,6 +41,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Transport.Client (TransportHost)
 
@@ -61,7 +62,8 @@ schemaMigrations =
     ("m20230110_users", m20230110_users),
     ("m20230117_fkey_indexes", m20230117_fkey_indexes),
     ("m20230120_delete_errors", m20230120_delete_errors),
-    ("m20230217_server_key_hash", m20230217_server_key_hash)
+    ("m20230217_server_key_hash", m20230217_server_key_hash),
+    ("m20230223_files", m20230223_files)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230223_files :: Query
+m20230223_files =
+  [sql|
+CREATE TABLE xftp_servers (
+  xftp_server_id INTEGER PRIMARY KEY,
+  xftp_host TEXT NOT NULL,
+  xftp_port TEXT NOT NULL,
+  xftp_key_hash BLOB NOT NULL,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now')),
+  UNIQUE(xftp_host, xftp_port, xftp_key_hash)
+);
+
+CREATE TABLE rcv_files (
+  rcv_file_id INTEGER PRIMARY KEY,
+  rcv_file_entity_id BLOB NOT NULL,
+  user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
+  size INTEGER NOT NULL,
+  digest BLOB NOT NULL,
+  key BLOB NOT NULL,
+  nonce BLOB NOT NULL,
+  chunk_size INTEGER NOT NULL,
+  prefix_path TEXT NOT NULL,
+  tmp_path TEXT,
+  save_path TEXT NOT NULL,
+  status TEXT NOT NULL,
+  deleted INTEGER NOT NULL DEFAULT 0,
+  error TEXT,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now')),
+  UNIQUE(rcv_file_entity_id)
+);
+
+CREATE INDEX idx_rcv_files_user_id ON rcv_files(user_id);
+
+CREATE TABLE rcv_file_chunks (
+  rcv_file_chunk_id INTEGER PRIMARY KEY,
+  rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE,
+  chunk_no INTEGER NOT NULL,
+  chunk_size INTEGER NOT NULL,
+  digest BLOB NOT NULL,
+  tmp_path TEXT,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id);
+
+CREATE TABLE rcv_file_chunk_replicas (
+  rcv_file_chunk_replica_id INTEGER PRIMARY KEY,
+  rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE,
+  replica_number INTEGER NOT NULL,
+  xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
+  replica_id BLOB NOT NULL,
+  replica_key BLOB NOT NULL,
+  received INTEGER NOT NULL DEFAULT 0,
+  delay INTEGER,
+  retries INTEGER NOT NULL DEFAULT 0,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id ON rcv_file_chunk_replicas(rcv_file_chunk_id);
+CREATE INDEX idx_rcv_file_chunk_replicas_xftp_server_id ON rcv_file_chunk_replicas(xftp_server_id);
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+-- this migration is a draft - it is not included in the list of migrations
+m20230401_snd_files :: Query
+m20230401_snd_files =
+  [sql|
+CREATE TABLE snd_files (
+  snd_file_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
+  size INTEGER NOT NULL,
+  digest BLOB NOT NULL,
+  key BLOB NOT NULL,
+  nonce BLOB NOT NULL,
+  chunk_size INTEGER NOT NULL,
+  path TEXT NOT NULL,
+  enc_path TEXT,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_snd_files_user_id ON snd_files(user_id);
+
+CREATE TABLE snd_file_chunks (
+  snd_file_chunk_id INTEGER PRIMARY KEY,
+  snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE,
+  chunk_no INTEGER NOT NULL,
+  chunk_offset INTEGER NOT NULL,
+  chunk_size INTEGER NOT NULL,
+  digest BLOB NOT NULL,
+  delay INTEGER,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_snd_file_chunks_snd_file_id ON snd_file_chunks(snd_file_id);
+
+-- ? add fk to snd_file_descriptions?
+-- ? probably it's not necessary since these entities are
+-- ? required at different stages of sending files -
+-- ? replicas on upload, description on notifying client
+CREATE TABLE snd_file_chunk_replicas (
+  snd_file_chunk_replica_id INTEGER PRIMARY KEY,
+  snd_file_chunk_id INTEGER NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE,
+  replica_number INTEGER NOT NULL,
+  xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
+  replica_id BLOB NOT NULL,
+  replica_key BLOB NOT NULL,
+  -- created INTEGER NOT NULL DEFAULT 0, -- as in XFTP create - registered on server
+  uploaded INTEGER NOT NULL DEFAULT 0,
+  retries INTEGER NOT NULL DEFAULT 0,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_snd_file_chunk_replicas_snd_file_chunk_id ON snd_file_chunk_replicas(snd_file_chunk_id);
+CREATE INDEX idx_snd_file_chunk_replicas_xftp_server_id ON snd_file_chunk_replicas(xftp_server_id);
+
+CREATE TABLE snd_file_chunk_replica_recipients (
+  snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY,
+  snd_file_chunk_replica_id INTEGER NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE,
+  rcv_replica_id BLOB NOT NULL,
+  rcv_replica_key BLOB NOT NULL,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id ON snd_file_chunk_replica_recipients(snd_file_chunk_replica_id);
+
+CREATE TABLE snd_file_descriptions (
+  snd_file_description_id INTEGER PRIMARY KEY,
+  snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE,
+  sender INTEGER NOT NULL, -- 1 for sender file description
+  descr_text TEXT NOT NULL,
+  created_at TEXT NOT NULL DEFAULT (datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT (datetime('now'))
+);
+
+CREATE INDEX idx_snd_file_descriptions_snd_file_id ON snd_file_descriptions(snd_file_id);
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql

@@ -283,3 +283,62 @@ CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(
   internal_id
 );
 CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port);
+CREATE TABLE xftp_servers(
+  xftp_server_id INTEGER PRIMARY KEY,
+  xftp_host TEXT NOT NULL,
+  xftp_port TEXT NOT NULL,
+  xftp_key_hash BLOB NOT NULL,
+  created_at TEXT NOT NULL DEFAULT(datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  UNIQUE(xftp_host, xftp_port, xftp_key_hash)
+);
+CREATE TABLE rcv_files(
+  rcv_file_id INTEGER PRIMARY KEY,
+  rcv_file_entity_id BLOB NOT NULL,
+  user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
+  size INTEGER NOT NULL,
+  digest BLOB NOT NULL,
+  key BLOB NOT NULL,
+  nonce BLOB NOT NULL,
+  chunk_size INTEGER NOT NULL,
+  prefix_path TEXT NOT NULL,
+  tmp_path TEXT,
+  save_path TEXT NOT NULL,
+  status TEXT NOT NULL,
+  deleted INTEGER NOT NULL DEFAULT 0,
+  error TEXT,
+  created_at TEXT NOT NULL DEFAULT(datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  UNIQUE(rcv_file_entity_id)
+);
+CREATE INDEX idx_rcv_files_user_id ON rcv_files(user_id);
+CREATE TABLE rcv_file_chunks(
+  rcv_file_chunk_id INTEGER PRIMARY KEY,
+  rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE,
+  chunk_no INTEGER NOT NULL,
+  chunk_size INTEGER NOT NULL,
+  digest BLOB NOT NULL,
+  tmp_path TEXT,
+  created_at TEXT NOT NULL DEFAULT(datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT(datetime('now'))
+);
+CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id);
+CREATE TABLE rcv_file_chunk_replicas(
+  rcv_file_chunk_replica_id INTEGER PRIMARY KEY,
+  rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE,
+  replica_number INTEGER NOT NULL,
+  xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE,
+  replica_id BLOB NOT NULL,
+  replica_key BLOB NOT NULL,
+  received INTEGER NOT NULL DEFAULT 0,
+  delay INTEGER,
+  retries INTEGER NOT NULL DEFAULT 0,
+  created_at TEXT NOT NULL DEFAULT(datetime('now')),
+  updated_at TEXT NOT NULL DEFAULT(datetime('now'))
+);
+CREATE INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id ON rcv_file_chunk_replicas(
+  rcv_file_chunk_id
+);
+CREATE INDEX idx_rcv_file_chunk_replicas_xftp_server_id ON rcv_file_chunk_replicas(
+  xftp_server_id
+);

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -16,8 +16,8 @@ import Control.Concurrent.STM
 import qualified Data.Map.Strict as M
 import Data.Set (Set)
 import qualified Data.Set as S
-import Simplex.Messaging.Agent.Protocol (ConnId)
-import Simplex.Messaging.Agent.Store (RcvQueue (..), UserId)
+import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
+import Simplex.Messaging.Agent.Store (RcvQueue (..))
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM

src/Simplex/Messaging/Client.hs

@@ -31,7 +31,7 @@ module Simplex.Messaging.Client
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
-    clientServer,
+    protocolClientServer,
     transportHost',
     transportSession',
 
@@ -64,6 +64,7 @@ module Simplex.Messaging.Client
     transportClientConfig,
     chooseTransportHost,
     proxyUsername,
+    temporaryClientError,
     ServerTransmission,
     ClientCommand,
   )
@@ -253,8 +254,8 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts
     onionHost = find isOnionHost hosts
     publicHost = find (not . isOnionHost) hosts
 
-clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
-clientServer = B.unpack . strEncode . snd3 . transportSession . client_
+protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
+protocolClientServer = B.unpack . strEncode . snd3 . transportSession . client_
   where
     snd3 (_, s, _) = s
 
@@ -413,14 +414,21 @@ data ProtocolClientError err
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
-  | -- | Error when cryptographically "signing" the command.
-    PCESignatureError C.CryptoError
+  | -- | Error when cryptographically "signing" the command or when initializing crypto_box.
+    PCECryptoError C.CryptoError
   | -- | IO Error
     PCEIOError IOException
   deriving (Eq, Show, Exception)
 
 type SMPClientError = ProtocolClientError ErrorType
 
+temporaryClientError :: ProtocolClientError err -> Bool
+temporaryClientError = \case
+  PCENetworkError -> True
+  PCEResponseTimeout -> True
+  PCEIOError _ -> True
+  _ -> False
+
 -- | Create a new SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command

src/Simplex/Messaging/Crypto.hs

@@ -121,6 +121,7 @@ module Simplex.Messaging.Crypto
     sbEncrypt,
     sbDecrypt,
     sbKey,
+    unsafeSbKey,
     randomSbKey,
 
     -- * pseudo-random bytes
@@ -758,11 +759,19 @@ instance FromJSON Key where
 
 -- | IV bytes newtype.
 newtype IV = IV {unIV :: ByteString}
+  deriving (Eq, Show)
 
 instance Encoding IV where
   smpEncode = unIV
   smpP = IV <$> A.take (ivSize @AES256)
 
+instance ToJSON IV where
+  toJSON = strToJSON . unIV
+  toEncoding = strToJEncoding . unIV
+
+instance FromJSON IV where
+  parseJSON = fmap IV . strParseJSON "IV"
+
 -- | GCMIV bytes newtype.
 newtype GCMIV = GCMIV {unGCMIV :: ByteString}
 
@@ -1025,6 +1034,13 @@ instance ToJSON CbNonce where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance FromJSON CbNonce where
+  parseJSON = strParseJSON "CbNonce"
+
+instance FromField CbNonce where fromField f = CryptoBoxNonce <$> fromField f
+
+instance ToField CbNonce where toField (CryptoBoxNonce s) = toField s
+
 cbNonce :: ByteString -> CbNonce
 cbNonce s
   | len == 24 = CryptoBoxNonce s
@@ -1056,19 +1072,26 @@ pattern SbKey s <- SecretBoxKey s
 
 instance StrEncoding SbKey where
   strEncode (SbKey s) = strEncode s
-  strP = sbKey <$> strP
+  strP = sbKey <$?> strP
 
 instance ToJSON SbKey where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-sbKey :: ByteString -> SbKey
+instance FromJSON SbKey where
+  parseJSON = strParseJSON "SbKey"
+
+instance FromField SbKey where fromField f = SecretBoxKey <$> fromField f
+
+instance ToField SbKey where toField (SecretBoxKey s) = toField s
+
+sbKey :: ByteString -> Either String SbKey
 sbKey s
-  | len == 32 = SecretBoxKey s
-  | len > 32 = SecretBoxKey . fst $ B.splitAt 32 s
-  | otherwise = SecretBoxKey $ s <> B.replicate (32 - len) (toEnum 0)
-  where
-    len = B.length s
+  | B.length s == 32 = Right $ SecretBoxKey s
+  | otherwise = Left "SbKey: invalid length"
+
+unsafeSbKey :: ByteString -> SbKey
+unsafeSbKey s = either error id $ sbKey s
 
 randomSbKey :: IO SbKey
 randomSbKey = SecretBoxKey <$> getRandomBytes 32

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -1,33 +1,60 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Crypto.Lazy
-  ( sha512Hash,
+  ( sha256Hash,
+    sha512Hash,
     pad,
     unPad,
+    splitLen,
     sbEncrypt,
     sbDecrypt,
+    sbEncryptTailTag,
+    sbDecryptTailTag,
     fastReplicate,
+    SbState,
+    cbInit,
+    sbInit,
+    sbEncryptChunk,
+    sbDecryptChunk,
+    sbEncryptChunkLazy,
+    sbDecryptChunkLazy,
+    sbAuth,
+    LazyByteString,
   )
 where
 
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
 import Crypto.Hash (Digest, hashlazy)
-import Crypto.Hash.Algorithms (SHA512)
+import Crypto.Hash.Algorithms (SHA256, SHA512)
 import qualified Crypto.MAC.Poly1305 as Poly1305
+import Data.Bifunctor (first)
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
+import qualified Data.ByteString as S
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.ByteString.Lazy.Internal as LB
+import Data.Composition ((.:.))
 import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
 import Foreign (sizeOf)
-import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), SbKey, pattern CbNonce, pattern SbKey)
+import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
 import Simplex.Messaging.Encoding
 
 type LazyByteString = LB.ByteString
 
+-- | SHA512 digest of a lazy bytestring.
+sha256Hash :: LazyByteString -> ByteString
+sha256Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA256)
+
 -- | SHA512 digest of a lazy bytestring.
 sha512Hash :: LazyByteString -> ByteString
 sha512Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA512)
@@ -56,63 +83,129 @@ fastReplicate n c
 -- this function does not validate the length of the message to avoid consuming all chunks,
 -- so it can return a shorter string than expected
 unPad :: LazyByteString -> Either CryptoError LazyByteString
-unPad padded
+unPad = fmap snd . splitLen
+
+splitLen :: LazyByteString -> Either CryptoError (Int64, LazyByteString)
+splitLen padded
   | LB.length lenStr == 8 = case smpDecode $ LB.toStrict lenStr of
     Right len
       | len < 0 -> Left CryptoInvalidMsgError
-      | otherwise -> Right $ LB.take len rest
+      | otherwise -> Right (len, LB.take len rest)
     Left _ -> Left CryptoInvalidMsgError
   | otherwise = Left CryptoInvalidMsgError
   where
     (lenStr, rest) = LB.splitAt 8 padded
 
 -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce.
+-- The resulting string will be bigger than paddedLen by the size of the auth tag (16 bytes).
 sbEncrypt :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
-sbEncrypt (SbKey key) = sbEncrypt_ key
-
-sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
-sbEncrypt_ secret (CbNonce nonce) msg len paddedLen = cryptoBox secret nonce =<< pad msg len paddedLen
+sbEncrypt (SbKey key) (CbNonce nonce) msg len paddedLen =
+  prependTag <$> (secretBox sbEncryptChunk key nonce =<< pad msg len paddedLen)
+  where
+    prependTag (tag :| cs) = LB.Chunk tag $ LB.fromChunks cs
 
 -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
+-- The resulting string will be smaller than packet size by the size of the auth tag (16 bytes).
 sbDecrypt :: SbKey -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString
-sbDecrypt (SbKey key) = sbDecrypt_ key
-
--- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
-sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString
-sbDecrypt_ secret (CbNonce nonce) packet
+sbDecrypt (SbKey key) (CbNonce nonce) packet
   | LB.length tag' < 16 = Left CBDecryptError
-  | otherwise = case poly1305auth rs c of
-    Right tag
-      | BA.constEq (LB.toStrict tag') tag -> unPad msg
+  | otherwise = case secretBox sbDecryptChunk key nonce c of
+    Right (tag :| cs)
+      | BA.constEq (LB.toStrict tag') tag -> unPad $ LB.fromChunks cs
       | otherwise -> Left CBDecryptError
     Left e -> Left e
   where
     (tag', c) = LB.splitAt 16 packet
-    (rs, msg) = xSalsa20 secret nonce c
 
-cryptoBox :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> Either CryptoError LazyByteString
-cryptoBox secret nonce s = (<> c) . LB.fromStrict . BA.convert <$> tag
+secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString)
+secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
-    (rs, c) = xSalsa20 secret nonce s
-    tag = poly1305auth rs c
+    run state =
+      let (!cs, !state') = secretBoxLazy_ sbProcess state msg
+       in BA.convert (sbAuth state') :| reverse cs
 
-poly1305auth :: ByteString -> LazyByteString -> Either CryptoError Poly1305.Auth
-poly1305auth rs c = authTag <$> cryptoPassed (Poly1305.initialize rs)
+-- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
+sbEncryptTailTag :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
+sbEncryptTailTag (SbKey key) (CbNonce nonce) msg len paddedLen =
+  LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen)
+
+-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
+-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag.
+sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
+sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet =
+  case secretBox sbDecryptChunk key nonce c of
+    Right (tag :| cs) ->
+      let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag
+       in (valid,) <$> unPad (LB.fromChunks cs)
+    Left e -> Left e
   where
-    authTag state = Poly1305.finalize $ Poly1305.updates state $ LB.toChunks c
-    cryptoPassed = \case
-      CE.CryptoPassed a -> Right a
-      CE.CryptoFailed e -> Left $ CryptoPoly1305Error e
+    (c, tag') = LB.splitAt paddedLen packet
 
-xSalsa20 :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> (ByteString, LazyByteString)
-xSalsa20 secret nonce msg = (rs, msg')
+secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
+secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
+  where
+    run state =
+      let (cs, state') = secretBoxLazy_ sbProcess state msg
+       in reverse $ BA.convert (sbAuth state') : cs
+
+-- passes lazy bytestring via initialized secret box returning the reversed list of chunks
+secretBoxLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> ([ByteString], SbState)
+secretBoxLazy_ sbProcess state = foldlChunks update ([], state)
+  where
+    update (cs, st) chunk = let (!c, !st') = sbProcess st chunk in (c : cs, st')
+
+type SbState = (XSalsa.State, Poly1305.State)
+
+cbInit :: DhSecretX25519 -> CbNonce -> Either CryptoError SbState
+cbInit (DhSecretX25519 secret) (CbNonce nonce) = sbInit_ secret nonce
+{-# INLINE cbInit #-}
+
+sbInit :: SbKey -> CbNonce -> Either CryptoError SbState
+sbInit (SbKey secret) (CbNonce nonce) = sbInit_ secret nonce
+{-# INLINE sbInit #-}
+
+sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState
+sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
   where
     zero = B.replicate 16 $ toEnum 0
     (iv0, iv1) = B.splitAt 8 nonce
     state0 = XSalsa.initialize 20 secret (zero `B.append` iv0)
     state1 = XSalsa.derive state0 iv1
-    (rs, state2) = XSalsa.generate state1 32
-    (msg', _) = foldl update (LB.empty, state2) $ LB.toChunks msg
-    update (acc, state) chunk =
-      let (c, state') = XSalsa.combine state chunk
-       in (acc `LB.append` LB.fromStrict c, state')
+    (rs :: ByteString, state2) = XSalsa.generate state1 32
+
+sbEncryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState)
+sbEncryptChunkLazy = sbProcessChunkLazy_ sbEncryptChunk
+
+sbDecryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState)
+sbDecryptChunkLazy = sbProcessChunkLazy_ sbDecryptChunk
+
+sbProcessChunkLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> (LazyByteString, SbState)
+sbProcessChunkLazy_ = first (LB.fromChunks . reverse) .:. secretBoxLazy_
+{-# INLINE sbProcessChunkLazy_ #-}
+
+sbEncryptChunk :: SbState -> ByteString -> (ByteString, SbState)
+sbEncryptChunk (st, authSt) chunk =
+  let (!c, !st') = XSalsa.combine st chunk
+      !authSt' = Poly1305.update authSt c
+   in (c, (st', authSt'))
+
+sbDecryptChunk :: SbState -> ByteString -> (ByteString, SbState)
+sbDecryptChunk (st, authSt) chunk =
+  let (!s, !st') = XSalsa.combine st chunk
+      !authSt' = Poly1305.update authSt chunk
+   in (s, (st', authSt'))
+
+sbAuth :: SbState -> Poly1305.Auth
+sbAuth = Poly1305.finalize . snd
+
+cryptoPassed :: CE.CryptoFailable b -> Either CryptoError b
+cryptoPassed = \case
+  CE.CryptoPassed a -> Right a
+  CE.CryptoFailed e -> Left $ CryptoPoly1305Error e
+
+foldlChunks :: (a -> S.ByteString -> a) -> a -> LazyByteString -> a
+foldlChunks f = go
+  where
+    go !a LB.Empty = a
+    go !a (LB.Chunk c cs) = go (f a c) cs
+{-# INLINE foldlChunks #-}

src/Simplex/Messaging/Encoding/String.hs

@@ -36,7 +36,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Time.Format.ISO8601
-import Data.Word (Word16)
+import Data.Word (Word16, Word32)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$?>))
@@ -75,6 +75,10 @@ instance StrEncoding Str where
   strEncode = unStr
   strP = Str <$> A.takeTill (== ' ') <* optional A.space
 
+instance StrEncoding String where
+  strEncode = strEncode . B.pack
+  strP = B.unpack <$> strP
+
 instance ToJSON Str where
   toJSON (Str s) = strToJSON s
   toEncoding (Str s) = strToJEncoding s
@@ -94,6 +98,12 @@ instance StrEncoding Word16 where
   strP = A.decimal
   {-# INLINE strP #-}
 
+instance StrEncoding Word32 where
+  strEncode = B.pack . show
+  {-# INLINE strEncode #-}
+  strP = A.decimal
+  {-# INLINE strP #-}
+
 instance StrEncoding Char where
   strEncode = smpEncode
   {-# INLINE strEncode #-}

src/Simplex/Messaging/Notifications/Server.hs

@@ -235,7 +235,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       PCEResponseError e -> updateErr "ResponseError " e
       PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
       PCETransportError e -> updateErr "TransportError " e
-      PCESignatureError e -> updateErr "SignatureError " e
+      PCECryptoError e -> updateErr "CryptoError " e
       PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
       PCEResponseTimeout -> pure ()
       PCENetworkError -> pure ()

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -343,7 +343,8 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
   nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
   req <- liftIO $ apnsRequest c tknStr apnsNtf
-  HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req
+  -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
+  HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing
   let status = H.responseStatus response
       reason' = maybe "" reason $ J.decodeStrict' bodyHead
   logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'

src/Simplex/Messaging/Protocol.hs

@@ -65,6 +65,7 @@ module Simplex.Messaging.Protocol
     PrivHeader (..),
     Protocol (..),
     ProtocolType (..),
+    SProtocolType (..),
     AProtocolType (..),
     ProtocolTypeI (..),
     ProtocolServer (..),
@@ -74,7 +75,11 @@ module Simplex.Messaging.Protocol
     SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    XFTPServer,
+    pattern XFTPServer,
+    XFTPServerWithAuth,
     ProtoServerWithAuth (..),
+    AProtoServerWithAuth (..),
     BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
@@ -165,7 +170,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
-import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
@@ -623,6 +628,15 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
 
 {-# COMPLETE NtfServer #-}
 
+type XFTPServer = ProtocolServer 'PXFTP
+
+pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP
+pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash
+
+{-# COMPLETE XFTPServer #-}
+
+type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP
+
 sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
 sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
 {-# INLINE sameSrvAddr' #-}
@@ -631,22 +645,25 @@ sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
 sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
 {-# INLINE sameSrvAddr #-}
 
-data ProtocolType = PSMP | PNTF
+data ProtocolType = PSMP | PNTF | PXFTP
   deriving (Eq, Ord, Show)
 
 instance StrEncoding ProtocolType where
   strEncode = \case
     PSMP -> "smp"
     PNTF -> "ntf"
+    PXFTP -> "xftp"
   strP =
     A.takeTill (\c -> c == ':' || c == ' ') >>= \case
       "smp" -> pure PSMP
       "ntf" -> pure PNTF
+      "xftp" -> pure PXFTP
       _ -> fail "bad ProtocolType"
 
 data SProtocolType (p :: ProtocolType) where
   SPSMP :: SProtocolType 'PSMP
   SPNTF :: SProtocolType 'PNTF
+  SPXFTP :: SProtocolType 'PXFTP
 
 deriving instance Eq (SProtocolType p)
 
@@ -664,17 +681,20 @@ instance Eq AProtocolType where
 instance TestEquality SProtocolType where
   testEquality SPSMP SPSMP = Just Refl
   testEquality SPNTF SPNTF = Just Refl
+  testEquality SPXFTP SPXFTP = Just Refl
   testEquality _ _ = Nothing
 
 protocolType :: SProtocolType p -> ProtocolType
 protocolType = \case
   SPSMP -> PSMP
   SPNTF -> PNTF
+  SPXFTP -> PXFTP
 
 aProtocolType :: ProtocolType -> AProtocolType
 aProtocolType = \case
   PSMP -> AProtocolType SPSMP
   PNTF -> AProtocolType SPNTF
+  PXFTP -> AProtocolType SPXFTP
 
 instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
   strEncode = strEncode . protocolType
@@ -700,6 +720,8 @@ instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP
 
 instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
 
+instance ProtocolTypeI 'PXFTP where protocolTypeI = SPXFTP
+
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
   { scheme :: SProtocolType p,
@@ -709,6 +731,8 @@ data ProtocolServer p = ProtocolServer
   }
   deriving (Eq, Ord, Show)
 
+data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p)
+
 instance ProtocolTypeI p => IsString (ProtocolServer p) where
   fromString = parseString strDecode
 
@@ -724,15 +748,18 @@ instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
     strEncodeServer scheme (strEncode host) port keyHash Nothing
   strP =
     serverStrP >>= \case
-      (srv, Nothing) -> pure srv
+      (AProtocolServer _ srv, Nothing) -> either fail pure $ checkProtocolType srv
       _ -> fail "ProtocolServer with basic auth not allowed"
 
 instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance ProtocolTypeI p => FromJSON (ProtocolServer p) where
+  parseJSON = strParseJSON "ProtocolServer"
+
 newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 instance IsString BasicAuth where fromString = BasicAuth . B.pack
 
@@ -752,15 +779,25 @@ basicAuth s
     valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'
 
 data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer p, serverBasicAuth :: Maybe BasicAuth}
-  deriving (Show)
+  deriving (Eq, Ord, Show)
 
 instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
   fromString = parseString strDecode
 
+data AProtoServerWithAuth = forall p. ProtocolTypeI p => AProtoServerWithAuth (SProtocolType p) (ProtoServerWithAuth p)
+
+deriving instance Show AProtoServerWithAuth
+
 instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
   strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
     strEncodeServer scheme (strEncode host) port keyHash auth_
-  strP = uncurry ProtoServerWithAuth <$> serverStrP
+  strP = (\(AProtoServerWithAuth _ srv) -> checkProtocolType srv) <$?> strP
+
+instance StrEncoding AProtoServerWithAuth where
+  strEncode (AProtoServerWithAuth _ srv) = strEncode srv
+  strP =
+    serverStrP >>= \(AProtocolServer p srv, auth) ->
+      pure $ AProtoServerWithAuth p (ProtoServerWithAuth srv auth)
 
 instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
   toJSON = strToJSON
@@ -769,6 +806,13 @@ instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
 instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
   parseJSON = strParseJSON "ProtoServerWithAuth"
 
+instance ToJSON AProtoServerWithAuth where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON AProtoServerWithAuth where
+  parseJSON = strParseJSON "AProtoServerWithAuth"
+
 noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
 noAuthSrv srv = ProtoServerWithAuth srv Nothing
 
@@ -791,14 +835,15 @@ strEncodeServer scheme host port keyHash auth_ =
   where
     portStr = B.pack $ if null port then "" else ':' : port
 
-serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
+serverStrP :: Parser (AProtocolServer, Maybe BasicAuth)
 serverStrP = do
   scheme <- strP <* "://"
   keyHash <- strP
   auth_ <- optional $ A.char ':' *> strP
   TransportHosts host <- A.char '@' *> strP
   port <- portP <|> pure ""
-  pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
+  pure $ case scheme of
+    AProtocolType s -> (AProtocolServer s $ ProtocolServer {scheme = s, host, port, keyHash}, auth_)
   where
     portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
@@ -1133,9 +1178,7 @@ checkParty c = case testEquality (sParty @p) (sParty @p') of
   Nothing -> Left "bad command party"
 
 checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p)
-checkParty' c = case testEquality (sParty @p) (sParty @p') of
-  Just Refl -> Just c
-  _ -> Nothing
+checkParty' = eitherToMaybe . checkParty
 
 instance Encoding ErrorType where
   smpEncode = \case
@@ -1214,7 +1257,7 @@ tPut th trs
                 Just ts' -> encodeBatch n' s' ts'
                 _ -> (n', s', Nothing)
 
-tEncode :: C.CryptoSignature s => (s, ByteString) -> ByteString
+tEncode :: (Maybe C.ASignature, ByteString) -> ByteString
 tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t
 
 tEncodeBatch :: Int -> ByteString -> ByteString

src/Simplex/Messaging/Server.hs

@@ -300,7 +300,7 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
 data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 
 verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
-verifyTransmission sig_ signed queueId cmd = do
+verifyTransmission sig_ signed queueId cmd =
   case cmd of
     Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
@@ -311,7 +311,7 @@ verifyTransmission sig_ signed queueId cmd = do
     verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
     verifyCmd party f = do
       st <- asks queueStore
-      q_ <- atomically (getQueue st party queueId)
+      q_ <- atomically $ getQueue st party queueId
       pure $ case q_ of
         Right q -> Just q `verified` f q
         _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed

src/Simplex/Messaging/Server/CLI.hs

@@ -16,6 +16,7 @@ import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
@@ -24,7 +25,7 @@ import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..)
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (loadFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (whenM)
+import Simplex.Messaging.Util (eitherToMaybe, whenM)
 import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
@@ -170,6 +171,9 @@ iniOnOff section name ini = case lookupValue section name ini of
   Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s
   _ -> Nothing
 
+strDecodeIni :: StrEncoding a => Text -> Text -> Ini -> Maybe (Either String a)
+strDecodeIni section name ini = strDecode . encodeUtf8 <$> eitherToMaybe (lookupValue section name ini)
+
 withPrompt :: String -> IO a -> IO a
 withPrompt s a = putStr s >> hFlush stdout >> a
 

src/Simplex/Messaging/Server/Main.hs

@@ -178,9 +178,7 @@ smpServerCLI cfgPath logPath =
                       _ -> enableStoreLog $> messagesPath,
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
-              newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of
-                Right auth -> either error Just . strDecode $ encodeUtf8 auth
-                _ -> Nothing,
+              newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
               messageExpiration = Just defaultMessageExpiration,
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini

src/Simplex/Messaging/Transport.hs

@@ -204,11 +204,10 @@ instance Transport TLS where
   tlsUnique = tlsUniq
   closeConnection tls = closeTLS $ tlsContext tls
 
+  -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
+  -- this function may return less than requested number of bytes
   cGet :: TLS -> Int -> IO ByteString
-  cGet TLS {tlsContext, tlsBuffer} n = do
-    s <- getBuffered tlsBuffer n (T.recvData tlsContext)
-    -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-    if B.length s == n then pure s else ioe_EOF
+  cGet TLS {tlsContext, tlsBuffer} n = getBuffered tlsBuffer n (T.recvData tlsContext)
 
   cPut :: TLS -> ByteString -> IO ()
   cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
@@ -303,7 +302,7 @@ transportErrorP =
   "BLOCK" $> TEBadBlock
     <|> "LARGE_MSG" $> TELargeMsg
     <|> "SESSION" $> TEBadSession
-    <|> TEHandshake <$> parseRead1
+    <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
 
 -- | Serialize SMP encrypted transport error.
 serializeTransportError :: TransportError -> ByteString
@@ -311,7 +310,7 @@ serializeTransportError = \case
   TEBadBlock -> "BLOCK"
   TELargeMsg -> "LARGE_MSG"
   TEBadSession -> "SESSION"
-  TEHandshake e -> bshow e
+  TEHandshake e -> "HANDSHAKE " <> bshow e
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
@@ -321,10 +320,11 @@ tPutBlock THandle {connection = c, blockSize} block =
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, blockSize} =
-  cGet c blockSize >>= \case
-    "" -> ioe_EOF
-    msg -> pure . first (const TELargeMsg) $ C.unPad msg
+tGetBlock THandle {connection = c, blockSize} = do
+  msg <- cGet c blockSize
+  if B.length msg == blockSize
+    then pure . first (const TELargeMsg) $ C.unPad msg
+    else ioe_EOF
 
 -- | Server SMP transport handshake.
 --

src/Simplex/Messaging/Transport/Buffer.hs

@@ -31,6 +31,8 @@ getBuffered tb@TBuffer {buffer} n getChunk = withBufferLock tb $ do
   b <- readChunks =<< readTVarIO buffer
   let (s, b') = B.splitAt n b
   atomically $ writeTVar buffer $! b'
+  -- This would prevent the need to pad auth tag in HTTP2
+  -- threadDelay 150
   pure s
   where
     readChunks :: ByteString -> IO ByteString

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -22,7 +22,7 @@ import qualified System.TimeManager as TI
 defaultHTTP2BufferSize :: BufferSize
 defaultHTTP2BufferSize = 32768
 
-withHTTP2 :: BufferSize -> (Config -> SessionId -> IO ()) -> TLS -> IO ()
+withHTTP2 :: BufferSize -> (Config -> SessionId -> IO a) -> TLS -> IO a
 withHTTP2 sz run c = E.bracket (allocHTTP2Config c sz) freeSimpleConfig (`run` tlsUniq c)
 
 allocHTTP2Config :: TLS -> BufferSize -> IO Config
@@ -56,25 +56,26 @@ data HTTP2Body = HTTP2Body
 
 class HTTP2BodyChunk a where
   getBodyChunk :: a -> IO ByteString
-  getBodeSize :: a -> Maybe Int
+  getBodySize :: a -> Maybe Int
 
 instance HTTP2BodyChunk HC.Response where
   getBodyChunk = HC.getResponseBodyChunk
   {-# INLINE getBodyChunk #-}
-  getBodeSize = HC.responseBodySize
-  {-# INLINE getBodeSize #-}
+  getBodySize = HC.responseBodySize
+  {-# INLINE getBodySize #-}
 
 instance HTTP2BodyChunk HS.Request where
   getBodyChunk = HS.getRequestBodyChunk
   {-# INLINE getBodyChunk #-}
-  getBodeSize = HS.requestBodySize
-  {-# INLINE getBodeSize #-}
+  getBodySize = HS.requestBodySize
+  {-# INLINE getBodySize #-}
 
 getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
 getHTTP2Body r n = do
   bodyBuffer <- atomically newTBuffer
   let getPart n' = getBuffered bodyBuffer n' $ getBodyChunk r
   bodyHead <- getPart n
-  let bodySize = fromMaybe 0 $ getBodeSize r
-      bodyPart = if bodySize > n && B.length bodyHead == n then Just getPart else Nothing
+  let bodySize = fromMaybe 0 $ getBodySize r
+      -- TODO check bodySize once it is set
+      bodyPart = if B.length bodyHead == n then Just getPart else Nothing
   pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer}

src/Simplex/Messaging/Transport/HTTP2/Client.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -6,10 +7,11 @@
 module Simplex.Messaging.Transport.HTTP2.Client where
 
 import Control.Concurrent.Async
-import Control.Exception (IOException)
+import Control.Exception (IOException, try)
 import qualified Control.Exception as E
 import Control.Monad.Except
 import Data.ByteString.Char8 (ByteString)
+import Data.Functor (($>))
 import Data.Time (UTCTime, getCurrentTime)
 import qualified Data.X509.CertificateStore as XS
 import Network.HPACK (BufferSize)
@@ -27,14 +29,16 @@ import UnliftIO.STM
 import UnliftIO.Timeout
 
 data HTTP2Client = HTTP2Client
-  { action :: Maybe (Async ()),
+  { action :: Maybe (Async HTTP2Response),
     sessionId :: SessionId,
     sessionTs :: UTCTime,
+    sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response,
     client_ :: HClient
   }
 
 data HClient = HClient
   { connected :: TVar Bool,
+    disconnected :: IO (),
     host :: TransportHost,
     port :: ServiceName,
     config :: HTTP2ClientConfig,
@@ -82,7 +86,7 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien
     mkHTTPS2Client = do
       connected <- newTVar False
       reqQ <- newTBQueue $ qSize config
-      pure HClient {connected, host, port, config, reqQ}
+      pure HClient {connected, disconnected, host, port, config, reqQ}
 
     runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
     runClient c = do
@@ -97,34 +101,54 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien
         Just (Left e) -> Left e
         Nothing -> Left HCNetworkError
 
-    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client ()
+    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client HTTP2Response
     client c cVar sessionId sendReq = do
       sessionTs <- getCurrentTime
-      let c' = HTTP2Client {action = Nothing, client_ = c, sessionId, sessionTs}
+      let c' = HTTP2Client {action = Nothing, client_ = c, sendReq, sessionId, sessionTs}
       atomically $ do
         writeTVar (connected c) True
         putTMVar cVar (Right c')
       process c' sendReq `E.finally` disconnected
 
-    process :: HTTP2Client -> H.Client ()
+    process :: HTTP2Client -> H.Client HTTP2Response
     process HTTP2Client {client_ = HClient {reqQ}} sendReq = forever $ do
       (req, respVar) <- atomically $ readTBQueue reqQ
       sendReq req $ \r -> do
         respBody <- getHTTP2Body r bodyHeadSize
-        atomically $ putTMVar respVar HTTP2Response {response = r, respBody}
+        let resp = HTTP2Response {response = r, respBody}
+        atomically $ putTMVar respVar resp
+        pure resp
 
 -- | Disconnects client from the server and terminates client threads.
 closeHTTP2Client :: HTTP2Client -> IO ()
 closeHTTP2Client = mapM_ uninterruptibleCancel . action
 
-sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
-sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req = do
+sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
+sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req reqTimeout_ = do
   resp <- newEmptyTMVarIO
   atomically $ writeTBQueue reqQ (req, resp)
-  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
+  let reqTimeout = http2RequestTimeout config reqTimeout_
+  maybe (Left HCResponseTimeout) Right <$> (reqTimeout `timeout` atomically (takeTMVar resp))
 
-runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client ()) -> IO ()
+-- | this function should not be used until HTTP2 is thread safe, use sendRequest
+sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
+sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req reqTimeout_ = do
+  let reqTimeout = http2RequestTimeout config reqTimeout_
+  reqTimeout `timeout` try (sendReq req process) >>= \case
+    Just (Right r) -> pure $ Right r
+    Just (Left e) -> disconnected $> Left (HCIOError e)
+    Nothing -> pure $ Left HCNetworkError
+  where
+    process r = do
+      respBody <- getHTTP2Body r $ bodyHeadSize config
+      pure HTTP2Response {response = r, respBody}
+
+http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
+http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
+
+runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client a) -> IO a
 runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash client =
   runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash $ withHTTP2 bufferSize run
   where
+    run :: H.Config -> SessionId -> IO a
     run cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg . client

src/Simplex/Messaging/Util.hs

@@ -55,6 +55,10 @@ liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a)
 liftEitherError f a = liftIOEither (first f <$> a)
 {-# INLINE liftEitherError #-}
 
+liftEitherWith :: (MonadError e' m) => (e -> e') -> Either e a -> m a
+liftEitherWith f = liftEither . first f
+{-# INLINE liftEitherWith #-}
+
 tryError :: MonadError e m => m a -> m (Either e a)
 tryError action = (Right <$> action) `catchError` (pure . Left)
 {-# INLINE tryError #-}

stack.yaml

@@ -48,6 +48,8 @@ extra-deps:
   - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
   - github: simplex-chat/aeson
     commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7
+  - github: kazu-yamamoto/http2
+    commit: 78e18f52295a7f89e828539a03fbcb24931461a3
   # - ../direct-sqlcipher
   - github: simplex-chat/direct-sqlcipher
     commit: 34309410eb2069b029b8fc1872deb1e0db123294

tests/AgentTests.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PostfixOperators #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests (agentTests) where
@@ -19,6 +20,7 @@ import Control.Concurrent
 import Control.Monad (forM_)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Type.Equality
 import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
 import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
@@ -81,45 +83,73 @@ agentTests (ATransport t) = do
     it "should resume delivering messages after exceeding quota once all messages are received" $
       smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
 
-tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
-tGetAgent h = do
-  t@(_, _, cmd) <- tGet SAgent h
-  case cmd of
-    Right CONNECT {} -> tGetAgent h
-    Right DISCONNECT {} -> tGetAgent h
-    _ -> pure t
+type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e)
+
+type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e))
+
+tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
+tGetAgent = tGetAgent'
+
+tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e)
+tGetAgent' h = do
+  (corrId, connId, cmdOrErr) <- pGetAgent h
+  case cmdOrErr of
+    Right (APC e cmd) -> case testEquality e (sAEntity @e) of
+      Just Refl -> pure (corrId, connId, Right cmd)
+      _ -> error $ "unexpected command " <> show cmd
+    Left err -> pure (corrId, connId, Left err)
+
+pGetAgent :: forall c. Transport c => c -> IO (ATransmissionOrError 'Agent)
+pGetAgent h = do
+  (corrId, connId, cmdOrErr) <- tGet SAgent h
+  case cmdOrErr of
+    Right (APC _ CONNECT {}) -> pGetAgent h
+    Right (APC _ DISCONNECT {}) -> pGetAgent h
+    cmd -> pure (corrId, connId, cmd)
 
 -- | receive message to handle `h`
-(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
 (<#:) = tGetAgent
 
+(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+(<#:?) = pGetAgent
+
+(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone)
+(<#:.) = tGetAgent'
+
 -- | send transmission `t` to handle `h` and get response
-(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
+(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
 h #: t = tPutRaw h t >> (<#:) h
 
 -- | action and expected response
 -- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
-(#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation
+(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation
 action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right cmd)
 
 -- | action and predicate for the response
 -- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p`
-(=#>) :: IO (ATransmissionOrError 'Agent) -> (ATransmission 'Agent -> Bool) -> Expectation
+(=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
 action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)
 
-correctTransmission :: ATransmissionOrError a -> ATransmission a
+correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd)
 correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
   Right cmd -> (corrId, connId, cmd)
   Left e -> error $ show e
 
 -- | receive message to handle `h` and validate that it is the expected one
-(<#) :: Transport c => c -> ATransmission 'Agent -> Expectation
+(<#) :: Transport c => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
 h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd)
 
+(<#.) :: Transport c => c -> AEntityTransmission 'Agent 'AENone -> Expectation
+h <#. (corrId, connId, cmd) = (h <#:.) `shouldReturn` (corrId, connId, Right cmd)
+
 -- | receive message to handle `h` and validate it using predicate `p`
-(<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
+(<#=) :: Transport c => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
 h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
 
+(<#=?) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
+h <#=? p = (h <#:?) >>= (`shouldSatisfy` p . correctTransmission)
+
 -- | test that nothing is delivered to handle `h` during 10ms
 (#:#) :: Transport c => c -> String -> Expectation
 h #:# err = tryGet `shouldReturn` ()
@@ -129,7 +159,7 @@ h #:# err = tryGet `shouldReturn` ()
         Just _ -> error err
         _ -> return ()
 
-pattern Msg :: MsgBody -> ACommand 'Agent
+pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
@@ -288,7 +318,7 @@ testSubscrNotification t (server, _) client = do
   client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
-  client <# ("", "", DOWN testSMPServer ["conn1"])
+  client <#. ("", "", DOWN testSMPServer ["conn1"])
   withSmpServer (ATransport t) $
     client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
 
@@ -302,15 +332,15 @@ testMsgDeliveryServerRestart t alice bob = do
     alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
     alice #:# "nothing else delivered before the server is killed"
 
-  let server = (SMPServer "localhost" testPort2 testKeyHash)
-  alice <# ("", "", DOWN server ["bob"])
+  let server = SMPServer "localhost" testPort2 testKeyHash
+  alice <#. ("", "", DOWN server ["bob"])
   bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5)
   bob #:# "nothing else delivered before the server is restarted"
   alice #:# "nothing else delivered before the server is restarted"
 
   withServer $ do
     bob <# ("", "alice", SENT 5)
-    alice <# ("", "", UP server ["bob"])
+    alice <#. ("", "", UP server ["bob"])
     alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
     alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
 
@@ -325,8 +355,8 @@ testServerConnectionAfterError t _ = do
       withServer $ do
         connect (bob, "bob") (alice, "alice")
 
-      bob <# ("", "", DOWN server ["alice"])
-      alice <# ("", "", DOWN server ["bob"])
+      bob <#. ("", "", DOWN server ["alice"])
+      alice <#. ("", "", DOWN server ["bob"])
       alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
       alice #:# "nothing else delivered before the server is restarted"
       bob #:# "nothing else delivered before the server is restarted"
@@ -336,10 +366,10 @@ testServerConnectionAfterError t _ = do
       bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
       alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
       withServer $ do
-        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
-        alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
-        bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
-        bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
+        alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
+        alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
+        bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
+        bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
         bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
         alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
         alice <# ("", "bob", SENT 5)
@@ -368,7 +398,7 @@ testMsgDeliveryAgentRestart t bob = do
       bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
       bob #:# "nothing else delivered before the server is down"
 
-    bob <# ("", "", DOWN server ["alice"])
+    bob <#. ("", "", DOWN server ["alice"])
     alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
     alice #:# "nothing else delivered before the server is restarted"
     bob #:# "nothing else delivered before the server is restarted"
@@ -381,8 +411,8 @@ testMsgDeliveryAgentRestart t bob = do
           (corrId == "3" && cmd == OK)
             || (corrId == "" && cmd == SENT 5)
         _ -> False
-      bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
-      bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
+      bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
+      bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
       bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
@@ -499,10 +529,8 @@ syntaxTests t = do
   it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
   describe "NEW" $ do
     describe "valid" $ do
-      -- TODO: add tests with defined connection id
       it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
     describe "invalid" $ do
-      -- TODO: add tests with defined connection id
       it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX")
 
   describe "JOIN" $ do

tests/AgentTests/FunctionalAPITests.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.FunctionalAPITests
@@ -19,6 +20,10 @@ module AgentTests.FunctionalAPITests
     runRight,
     runRight_,
     get,
+    get',
+    rfGet,
+    sfGet,
+    nGet,
     (##>),
     (=##>),
     pattern Msg,
@@ -38,13 +43,13 @@ import qualified Data.Map as M
 import Data.Maybe (isNothing)
 import qualified Data.Set as S
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Data.Type.Equality
 import SMPAgentClient
 import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -58,21 +63,42 @@ import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO
 
-(##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
+type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e)
+
+(##>) :: (HasCallStack, MonadIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m ()
 a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
 
-(=##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m ()
+(=##>) :: (Show a, HasCallStack, MonadIO m) => m a -> (a -> Bool) -> m ()
 a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
 
-get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
-get c = do
-  t@(_, _, cmd) <- atomically (readTBQueue $ subQ c)
+get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn)
+get = get' @'AEConn
+
+rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile)
+rfGet = get' @'AERcvFile
+
+sfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AESndFile)
+sfGet = get' @'AESndFile
+
+nGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AENone)
+nGet = get' @'AENone
+
+get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e)
+get' c = do
+  (corrId, connId, APC e cmd) <- pGet c
+  case testEquality e (sAEntity @e) of
+    Just Refl -> pure (corrId, connId, cmd)
+    _ -> error $ "unexpected command " <> show cmd
+
+pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent)
+pGet c = do
+  t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c)
   case cmd of
-    CONNECT {} -> get c
-    DISCONNECT {} -> get c
+    CONNECT {} -> pGet c
+    DISCONNECT {} -> pGet c
     _ -> pure t
 
-pattern Msg :: MsgBody -> ACommand 'Agent
+pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 smpCfgV1 :: ProtocolClientConfig
@@ -87,7 +113,7 @@ agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11}
 vr11 :: VersionRange
 vr11 = mkVersionRange 1 1
 
-runRight_ :: HasCallStack => ExceptT AgentErrorType IO () -> Expectation
+runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation
 runRight_ action = runExceptT action `shouldReturn` Right ()
 
 runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a
@@ -387,12 +413,12 @@ testAsyncServerOffline t = do
     runRight $ createConnection alice 1 True SCMInvitation Nothing
   -- connection fails
   Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo"
-  ("", "", DOWN srv conns) <- get alice
+  ("", "", DOWN srv conns) <- nGet alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
   -- connection succeeds after server start
   withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    ("", "", UP srv1 conns1) <- get alice
+    ("", "", UP srv1 conns1) <- nGet alice
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
@@ -439,8 +465,8 @@ testDuplicateMessage t = do
 
     pure (aliceId, bobId, bob1)
 
-  get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
-  get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+  nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+  nGet bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
   -- commenting two lines below and uncommenting further two lines would also runRight_,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
@@ -484,7 +510,7 @@ testInactiveClientDisconnected t = do
     alice <- getSMPAgentClient agentCfg initAgentServers
     runRight_ $ do
       (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing
-      get alice ##> ("", "", DOWN testSMPServer [connId])
+      nGet alice ##> ("", "", DOWN testSMPServer [connId])
 
 testActiveClientNotDisconnected :: ATransport -> IO ()
 testActiveClientNotDisconnected t = do
@@ -510,7 +536,7 @@ testActiveClientNotDisconnected t = do
           Nothing <- 800000 `timeout` get alice
           liftIO $ threadDelay 1200000
           -- and after 2 sec of inactivity DOWN is sent
-          get alice ##> ("", "", DOWN testSMPServer [connId])
+          nGet alice ##> ("", "", DOWN testSMPServer [connId])
     milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
 
 testSuspendingAgent :: IO ()
@@ -524,7 +550,7 @@ testSuspendingAgent = do
     get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
     ackMessage b aId 4
     suspendAgent b 1000000
-    get b ##> ("", "", SUSPENDED)
+    get' b ##> ("", "", SUSPENDED)
     5 <- sendMessage a bId SMP.noMsgFlags "hello 2"
     get a ##> ("", bId, SENT 5)
     Nothing <- 100000 `timeout` get b
@@ -544,21 +570,21 @@ testSuspendingAgentCompleteSending t = do
     pure (aId, bId)
 
   runRight_ $ do
-    ("", "", DOWN {}) <- get a
-    ("", "", DOWN {}) <- get b
+    ("", "", DOWN {}) <- nGet a
+    ("", "", DOWN {}) <- nGet b
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
     6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
     liftIO $ threadDelay 100000
     suspendAgent b 5000000
 
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
-    ("", "", SUSPENDED) <- get b
+  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do
+    pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
+    pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
+    pGet b =##> \case ("", c, APC _ (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
+    ("", "", SUSPENDED) <- nGet b
 
-    get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False
-    get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False
+    pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
+    pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
     ackMessage a bId 5
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
     ackMessage a bId 6
@@ -576,12 +602,12 @@ testSuspendingAgentTimeout t = do
     pure (aId, bId)
 
   runRight_ $ do
-    ("", "", DOWN {}) <- get a
-    ("", "", DOWN {}) <- get b
+    ("", "", DOWN {}) <- nGet a
+    ("", "", DOWN {}) <- nGet b
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
     6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
     suspendAgent b 100000
-    ("", "", SUSPENDED) <- get b
+    ("", "", SUSPENDED) <- nGet b
     pure ()
 
 testBatchedSubscriptions :: ATransport -> IO ()
@@ -596,15 +622,15 @@ testBatchedSubscriptions t = do
     delete b aIds'
     liftIO $ threadDelay 1000000
     pure conns
-  ("", "", DOWN {}) <- get a
-  ("", "", DOWN {}) <- get a
-  ("", "", DOWN {}) <- get b
-  ("", "", DOWN {}) <- get b
+  ("", "", DOWN {}) <- nGet a
+  ("", "", DOWN {}) <- nGet a
+  ("", "", DOWN {}) <- nGet b
+  ("", "", DOWN {}) <- nGet b
   runServers $ do
-    ("", "", UP {}) <- get a
-    ("", "", UP {}) <- get a
-    ("", "", UP {}) <- get b
-    ("", "", UP {}) <- get b
+    ("", "", UP {}) <- nGet a
+    ("", "", UP {}) <- nGet a
+    ("", "", UP {}) <- nGet b
+    ("", "", UP {}) <- nGet b
     liftIO $ threadDelay 1000000
     let (aIds, bIds) = unzip conns
         conns' = drop 10 conns
@@ -777,7 +803,7 @@ testUsers = do
     deleteUser a auId True
     get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False
     get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
-    get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
+    nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     exchangeGreetingsMsgId 6 a bId b aId
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
@@ -806,18 +832,18 @@ testUsersNoServer t = do
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     pure (aId, bId, auId, aId', bId')
-  get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
-  get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
-  get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
+  nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
+  nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
+  nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
   runRight_ $ do
     deleteUser a auId True
     get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
     get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
-    get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
+    nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     liftIO $ noMessages a "nothing else should be delivered to alice"
   withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
-    get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
-    get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
+    nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
+    nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
     exchangeGreetingsMsgId 6 a bId b aId
 
 testSwitchConnection :: InitialAgentServers -> IO ()
@@ -961,8 +987,8 @@ testTwoUsers = do
     b `hasClients` 1
     setNetworkConfig a nc {sessionMode = TSMEntity}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 2
 
     exchangeGreetingsMsgId 6 a bId1 b aId1
@@ -970,10 +996,10 @@ testTwoUsers = do
     liftIO $ threadDelay 250000
     setNetworkConfig a nc {sessionMode = TSMUser}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 1
 
     aUserId2 <- createUser a [noAuthSrv testSMPServer]
@@ -985,10 +1011,10 @@ testTwoUsers = do
     b `hasClients` 1
     setNetworkConfig a nc {sessionMode = TSMEntity}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 4
     exchangeGreetingsMsgId 8 a bId1 b aId1
     exchangeGreetingsMsgId 8 a bId1' b aId1'
@@ -997,14 +1023,14 @@ testTwoUsers = do
     liftIO $ threadDelay 250000
     setNetworkConfig a nc {sessionMode = TSMUser}
     liftIO $ threadDelay 250000
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", DOWN _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
-    ("", "", UP _ _) <- get a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", DOWN _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
+    ("", "", UP _ _) <- nGet a
     a `hasClients` 2
     exchangeGreetingsMsgId 10 a bId1 b aId1
     exchangeGreetingsMsgId 10 a bId1' b aId1'

tests/AgentTests/NotificationTests.hs

@@ -3,12 +3,13 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
+import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
@@ -464,13 +465,13 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     liftIO $ killThread threadId
     pure (aliceId, bobId)
 
-  runRight_ $ do
-    get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+  runRight_ @AgentErrorType $ do
+    nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+    nGet bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
 
   withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do
-    get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
+    nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
+    nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
     liftIO $ threadDelay 1000000
     5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT 5)

tests/AgentTests/SQLiteTests.hs

@@ -62,7 +62,6 @@ removeStore db = do
     close :: SQLiteStore -> IO ()
     close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st)
 
--- TODO add null port tests
 storeTests :: Spec
 storeTests = do
   withStore2 $ do
@@ -279,7 +278,6 @@ testDeleteRcvConn =
       `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
     deleteConn db "conn1"
       `shouldReturn` ()
-    -- TODO check queues are deleted as well
     getConn db "conn1"
       `shouldReturn` Left SEConnNotFound
 
@@ -292,7 +290,6 @@ testDeleteSndConn =
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
     deleteConn db "conn1"
       `shouldReturn` ()
-    -- TODO check queues are deleted as well
     getConn db "conn1"
       `shouldReturn` Left SEConnNotFound
 
@@ -306,7 +303,6 @@ testDeleteDuplexConn =
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
     deleteConn db "conn1"
       `shouldReturn` ()
-    -- TODO check queues are deleted as well
     getConn db "conn1"
       `shouldReturn` Left SEConnNotFound
 

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/CLITests.hs

@@ -4,6 +4,7 @@ module CLITests where
 
 import Data.Ini (lookupValue, readIniFile)
 import Data.List (isPrefixOf)
+import Simplex.FileTransfer.Server.Main (xftpServerCLI, xftpServerVersion)
 import Simplex.Messaging.Notifications.Server.Main
 import Simplex.Messaging.Server.Main
 import Simplex.Messaging.Transport (simplexMQVersion)
@@ -27,6 +28,12 @@ ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
 ntfLogPath :: FilePath
 ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications"
 
+fileCfgPath :: FilePath
+fileCfgPath = "tests/tmp/cli/etc/opt/simplex-files"
+
+fileLogPath :: FilePath
+fileLogPath = "tests/tmp/cli/etc/var/simplex-files"
+
 cliTests :: Spec
 cliTests = do
   describe "SMP server CLI" $ do
@@ -38,6 +45,9 @@ cliTests = do
   describe "Ntf server CLI" $ do
     it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
     it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
+  describe "XFTP server CLI" $ do
+    it "should initialize, start and delete the server (no store log)" $ xftpServerTest False
+    it "should initialize, start and delete the server (with store log)" $ xftpServerTest True
 
 smpServerTest :: Bool -> Bool -> IO ()
 smpServerTest storeLog basicAuth = do
@@ -78,3 +88,20 @@ ntfServerTest storeLog = do
   capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
     >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
+
+xftpServerTest :: Bool -> IO ()
+xftpServerTest storeLog = do
+  capture_ (withArgs (["init", "-p", "tests/tmp", "-q", "10gb"] <> ["-l" | storeLog]) $ xftpServerCLI fileCfgPath fileLogPath)
+    >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> fileCfgPath <> "/file-server.ini") `isPrefixOf`))
+  Right ini <- readIniFile $ fileCfgPath <> "/file-server.ini"
+  lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
+  lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
+  lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
+  doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True
+  r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ()))
+  r `shouldContain` ["SimpleX XFTP server v" <> xftpServerVersion]
+  r `shouldContain` (if storeLog then ["Store log: " <> fileLogPath <> "/file-server-store.log"] else ["Store log disabled."])
+  r `shouldContain` ["Listening on port 443..."]
+  capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath)
+    >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
+  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False

tests/CoreTests/CryptoTests.hs

@@ -78,6 +78,8 @@ cryptoTests = do
   describe "lazy secretbox" $ do
     testLazySecretBox
     testLazySecretBoxFile
+    testLazySecretBoxTailTag
+    testLazySecretBoxFileTailTag
   describe "AES GCM" $ do
     testAESGCM
   describe "X509 key encoding" $ do
@@ -152,6 +154,33 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s
   Right s'' <- LC.sbDecrypt k nonce <$> LB.readFile (f <> ".encrypted")
   s'' `shouldBe` s
 
+testLazySecretBoxTailTag :: Spec
+testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a random symmetric key (tail tag)" . ioProperty $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  pure $ \(s, pad) ->
+    let b = LE.encodeUtf8 $ LT.pack s
+        len = LB.length b
+        pad' = min (abs pad) 100000
+        paddedLen = len + pad' + 8
+        cipher = LC.sbEncryptTailTag k nonce b len paddedLen
+        plain = LC.sbDecryptTailTag k nonce paddedLen =<< cipher
+     in isRight cipher && cipher /= (snd <$> plain) && Right (True, b) == plain
+
+testLazySecretBoxFileTailTag :: Spec
+testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a random symmetric key (tail tag)" $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  let f = "tests/tmp/testsecretbox"
+      paddedLen = 4 * 1024 * 1024
+      len = 4 * 1000 * 1000 :: Int64
+      s = LC.fastReplicate len 'a'
+  Right s' <- pure $ LC.sbEncryptTailTag k nonce s len paddedLen
+  LB.writeFile (f <> ".encrypted") s'
+  Right (auth, s'') <- LC.sbDecryptTailTag k nonce paddedLen <$> LB.readFile (f <> ".encrypted")
+  s'' `shouldBe` s
+  auth `shouldBe` True
+
 testAESGCM :: Spec
 testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do
   k <- C.randomAesKey

tests/FileDescriptionTests.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module FileDescriptionTests where
+
+import Control.Exception (bracket_)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Yaml as Y
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import System.Directory (removeFile)
+import Test.Hspec
+
+fileDescriptionTests :: Spec
+fileDescriptionTests =
+  describe "file description parsing / serializing" $ do
+    it "parse YAML file description" testParseYAMLFileDescription
+    it "serialize YAML file description" testSerializeYAMLFileDescription
+    it "parse file description" testParseFileDescription
+    it "serialize file description" testSerializeFileDescription
+
+fileDescPath :: FilePath
+fileDescPath = "tests/fixtures/file_description.yaml"
+
+tmpFileDescPath :: FilePath
+tmpFileDescPath = "tests/tmp/file_description.yaml"
+
+testSbKey :: C.SbKey
+testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY="
+
+testCbNonce :: C.CbNonce
+testCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
+
+fileDesc :: FileDescription 'FRecipient
+fileDesc =
+  FileDescription
+    { party = SFRecipient,
+      size = FileSize $ mb 26,
+      digest = FileDigest "abc",
+      key = testSbKey,
+      nonce = testCbNonce,
+      chunkSize = defaultChunkSize,
+      chunks =
+        [ FileChunk
+            { chunkNo = 1,
+              digest = chunkDigest,
+              chunkSize = defaultChunkSize,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
+                ]
+            },
+          FileChunk
+            { chunkNo = 2,
+              digest = chunkDigest,
+              chunkSize = defaultChunkSize,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey}
+                ]
+            },
+          FileChunk
+            { chunkNo = 3,
+              digest = chunkDigest,
+              chunkSize = defaultChunkSize,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey}
+                ]
+            },
+          FileChunk
+            { chunkNo = 4,
+              digest = chunkDigest,
+              chunkSize = FileSize $ mb 2,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
+                ]
+            }
+        ]
+    }
+  where
+    defaultChunkSize = FileSize $ mb 8
+    replicaId = ChunkReplicaId "abc"
+    replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+    chunkDigest = FileDigest "ghi"
+
+yamlFileDesc :: YAMLFileDescription
+yamlFileDesc =
+  YAMLFileDescription
+    { party = FRecipient,
+      size = "26mb",
+      chunkSize = "8mb",
+      digest = FileDigest "abc",
+      key = testSbKey,
+      nonce = testCbNonce,
+      replicas =
+        [ YAMLServerReplicas
+            { server = "xftp://abc=@example1.com",
+              chunks =
+                [ "1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp",
+                  "3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp"
+                ]
+            },
+          YAMLServerReplicas
+            { server = "xftp://abc=@example2.com",
+              chunks =
+                [ "2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp",
+                  "4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp:2mb"
+                ]
+            },
+          YAMLServerReplicas
+            { server = "xftp://abc=@example3.com",
+              chunks =
+                [ "1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
+                  "4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+                ]
+            },
+          YAMLServerReplicas
+            { server = "xftp://abc=@example4.com",
+              chunks =
+                [ "2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
+                  "3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+                ]
+            }
+        ]
+    }
+
+testParseYAMLFileDescription :: IO ()
+testParseYAMLFileDescription = do
+  yfd <- Y.decodeFileThrow fileDescPath
+  yfd `shouldBe` yamlFileDesc
+
+testSerializeYAMLFileDescription :: IO ()
+testSerializeYAMLFileDescription = withRemoveTmpFile $ do
+  Y.encodeFile tmpFileDescPath yamlFileDesc
+  fdSer <- B.readFile tmpFileDescPath
+  fdExp <- B.readFile fileDescPath
+  fdSer `shouldBe` fdExp
+
+testParseFileDescription :: IO ()
+testParseFileDescription = do
+  r <- strDecode <$> B.readFile fileDescPath
+  case r of
+    Left e -> expectationFailure $ show e
+    Right fd -> fd `shouldBe` fileDesc
+
+testSerializeFileDescription :: IO ()
+testSerializeFileDescription = withRemoveTmpFile $ do
+  B.writeFile tmpFileDescPath $ strEncode fileDesc
+  fdSer <- B.readFile tmpFileDescPath
+  fdExp <- B.readFile fileDescPath
+  fdSer `shouldBe` fdExp
+
+withRemoveTmpFile :: IO () -> IO ()
+withRemoveTmpFile =
+  bracket_
+    (pure ())
+    (removeFile tmpFileDescPath)

tests/NtfClient.hs

@@ -30,6 +30,7 @@ import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
+import SMPClient (serverBracket)
 import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
@@ -48,7 +49,6 @@ import UnliftIO.Async
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
-import UnliftIO.Timeout (timeout)
 
 testHost :: NonEmpty TransportHost
 testHost = "localhost"
@@ -115,19 +115,6 @@ withNtfServerCfg t cfg =
     (\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]})
     (pure ())
 
-serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
-serverBracket process afterProcess f = do
-  started <- newEmptyTMVarIO
-  E.bracket
-    (forkIOWithUnmask ($ process started))
-    (\t -> killThread t >> afterProcess >> waitFor started "stop")
-    (\t -> waitFor started "start" >> f t)
-  where
-    waitFor started s =
-      5_000_000 `timeout` atomically (takeTMVar started) >>= \case
-        Nothing -> error $ "server did not " <> s
-        _ -> pure ()
-
 withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a
 withNtfServerOn t port' = withNtfServerThreadOn t port' . const
 

tests/SMPAgentClient.hs

@@ -29,14 +29,15 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
-import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
 import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
+import XFTPClient (testXFTPServer)
 
 agentTestHost :: NonEmpty TransportHost
 agentTestHost = "localhost"
@@ -65,8 +66,8 @@ smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
     get h = do
       t@(_, _, cmdStr) <- tGetRaw h
       case parseAll networkCommandP cmdStr of
-        Right (ACmd SAgent CONNECT {}) -> get h
-        Right (ACmd SAgent DISCONNECT {}) -> get h
+        Right (ACmd SAgent _ CONNECT {}) -> get h
+        Right (ACmd SAgent _ DISCONNECT {}) -> get h
         _ -> pure t
 
 runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a
@@ -178,6 +179,7 @@ initAgentServers =
   InitialAgentServers
     { smp = userServers [noAuthSrv testSMPServer],
       ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
+      xftp = userServers [noAuthSrv testXFTPServer],
       netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}
     }
 
@@ -208,7 +210,7 @@ withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
         (\started -> runSMPAgentBlocking t started cfg' initServers')
         afterProcess
 
-userServers :: NonEmpty SMPServerWithAuth -> Map UserId (NonEmpty SMPServerWithAuth)
+userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p))
 userServers srvs = M.fromList [(1, srvs)]
 
 withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> (ThreadId -> m a) -> m a

tests/Test.hs

@@ -8,6 +8,7 @@ import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
 import CoreTests.RetryIntervalTests
 import CoreTests.VersionRangeTests
+import FileDescriptionTests (fileDescriptionTests)
 import NtfServerTests (ntfServerTests)
 import ServerTests
 import Simplex.Messaging.Transport (TLS, Transport (..))
@@ -15,6 +16,9 @@ import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
+import XFTPAgent
+import XFTPCLI
+import XFTPServerTests (xftpServerTests)
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -39,4 +43,9 @@ main = do
         describe "SMP server via WebSockets" $ serverTests (transport @WS)
         describe "Notifications server" $ ntfServerTests (transport @TLS)
         describe "SMP client agent" $ agentTests (transport @TLS)
+        describe "XFTP" $ do
+          describe "XFTP server" xftpServerTests
+          describe "XFTP file description" fileDescriptionTests
+          describe "XFTP CLI" xftpCLITests
+          describe "XFTP agent" xftpAgentTests
         describe "Server CLIs" cliTests

tests/XFTPAgent.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module XFTPAgent where
+
+import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet)
+import Control.Logger.Simple
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Char8 as B
+import SMPAgentClient (agentCfg, initAgentServers)
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpDeleteRcvFile, xftpReceiveFile, xftpSendFile)
+import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import System.Directory (doesDirectoryExist, getFileSize, listDirectory)
+import System.FilePath ((</>))
+import System.Timeout (timeout)
+import Test.Hspec
+import XFTPCLI
+import XFTPClient
+
+xftpAgentTests :: Spec
+xftpAgentTests = around_ testBracket . describe "Functional API" $ do
+  it "should receive file" testXFTPAgentReceive
+  it "should resume receiving file after restart" testXFTPAgentReceiveRestore
+  it "should cleanup tmp path after permanent error" testXFTPAgentReceiveCleanup
+  it "should send file using experimental api" testXFTPAgentSendExperimental
+
+testXFTPAgentReceive :: IO ()
+testXFTPAgentReceive = withXFTPServer $ do
+  -- send file using CLI
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- B.readFile filePath
+  getFileSize filePath `shouldReturn` mb 17
+  let fdRcv = filePath <> ".xftp" </> "rcv1.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
+                 fdRcv
+               ]
+  -- receive file using agent
+  rcp <- getSMPAgentClient agentCfg initAgentServers
+  runRight_ $ do
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles)
+    ("", fId', RFDONE path) <- rfGet rcp
+    liftIO $ do
+      fId' `shouldBe` fId
+      B.readFile path `shouldReturn` file
+
+    -- delete file
+    xftpDeleteRcvFile rcp 1 fId
+
+getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
+getFileDescription path =
+  ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
+
+logCfgNoLogs :: LogConfig
+logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
+
+testXFTPAgentReceiveRestore :: IO ()
+testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
+  let filePath = senderFiles </> "testfile"
+      fdRcv = filePath <> ".xftp" </> "rcv1.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- send file using CLI
+    xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+    getFileSize filePath `shouldReturn` mb 17
+    progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+    progress `shouldSatisfy` uploadProgress
+    sendResult
+      `shouldBe` [ "Sender file description: " <> fdSnd,
+                   "Pass file descriptions to the recipient(s):",
+                   fdRcv
+                 ]
+
+  -- receive file using agent - should not succeed due to server being down
+  rcp <- getSMPAgentClient agentCfg initAgentServers
+  fId <- runRight $ do
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles)
+    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    pure fId
+  disconnectAgentClient rcp
+
+  [prefixDir] <- listDirectory recipientFiles
+  let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
+  doesDirectoryExist tmpPath `shouldReturn` True
+
+  rcp' <- getSMPAgentClient agentCfg initAgentServers
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- receive file using agent - should succeed with server up
+    ("", fId', RFDONE path) <- rfGet rcp'
+    liftIO $ do
+      fId' `shouldBe` fId
+      file <- B.readFile filePath
+      B.readFile path `shouldReturn` file
+
+  -- tmp path should be removed after receiving file
+  doesDirectoryExist tmpPath `shouldReturn` False
+
+testXFTPAgentReceiveCleanup :: IO ()
+testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
+  let filePath = senderFiles </> "testfile"
+      fdRcv = filePath <> ".xftp" </> "rcv1.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- send file using CLI
+    xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+    getFileSize filePath `shouldReturn` mb 17
+    progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+    progress `shouldSatisfy` uploadProgress
+    sendResult
+      `shouldBe` [ "Sender file description: " <> fdSnd,
+                   "Pass file descriptions to the recipient(s):",
+                   fdRcv
+                 ]
+
+  -- receive file using agent - should not succeed due to server being down
+  rcp <- getSMPAgentClient agentCfg initAgentServers
+  fId <- runRight $ do
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles)
+    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    pure fId
+  disconnectAgentClient rcp
+
+  [prefixDir] <- listDirectory recipientFiles
+  let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
+  doesDirectoryExist tmpPath `shouldReturn` True
+
+  -- receive file using agent - should fail with AUTH error
+  rcp' <- getSMPAgentClient agentCfg initAgentServers
+  withXFTPServerThreadOn $ \_ -> do
+    ("", fId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
+    fId' `shouldBe` fId
+
+  -- tmp path should be removed after permanent error
+  doesDirectoryExist tmpPath `shouldReturn` False
+
+testXFTPAgentSendExperimental :: IO ()
+testXFTPAgentSendExperimental = withXFTPServer $ do
+  -- create random file using cli
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- B.readFile filePath
+  getFileSize filePath `shouldReturn` mb 17
+
+  -- send file using experimental agent API
+  sndr <- getSMPAgentClient agentCfg initAgentServers
+  rfd <- runRight $ do
+    sfId <- xftpSendFile sndr 1 filePath 2 $ Just senderFiles
+    ("", sfId', SFDONE sndDescr rcvDescrs) <- sfGet sndr
+    liftIO $ do
+      sfId' `shouldBe` sfId
+      strDecode <$> B.readFile (senderFiles </> "testfile.descr/testfile.xftp/snd.xftp.private") `shouldReturn` Right sndDescr
+      Right rfd1 <- strDecode <$> B.readFile (senderFiles </> "testfile.descr/testfile.xftp/rcv1.xftp")
+      Right rfd2 <- strDecode <$> B.readFile (senderFiles </> "testfile.descr/testfile.xftp/rcv2.xftp")
+      rcvDescrs `shouldMatchList` [rfd1, rfd2]
+      pure rfd1
+
+  -- receive file using agent
+  rcp <- getSMPAgentClient agentCfg initAgentServers
+  runRight_ $ do
+    rfId <- xftpReceiveFile rcp 1 rfd (Just recipientFiles)
+    ("", rfId', RFDONE path) <- rfGet rcp
+    liftIO $ do
+      rfId' `shouldBe` rfId
+      B.readFile path `shouldReturn` file

tests/XFTPCLI.hs

@@ -0,0 +1,169 @@
+module XFTPCLI where
+
+import Control.Exception (bracket_)
+import qualified Data.ByteString as LB
+import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
+import Simplex.FileTransfer.Client.Main (prepareChunkSizes, xftpClientCLI)
+import Simplex.FileTransfer.Description (kb, mb)
+import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive)
+import System.Environment (withArgs)
+import System.FilePath ((</>))
+import System.IO.Silently (capture_)
+import Test.Hspec
+import XFTPClient (testXFTPServerStr, testXFTPServerStr2, withXFTPServer, withXFTPServer2, xftpServerFiles, xftpServerFiles2)
+
+xftpCLITests :: Spec
+xftpCLITests = around_ testBracket . describe "XFTP CLI" $ do
+  it "should send and receive file" testXFTPCLISendReceive
+  it "should send and receive file with 2 servers" testXFTPCLISendReceive2servers
+  it "should delete file from 2 servers" testXFTPCLIDelete
+  it "prepareChunkSizes should use 2 chunk sizes" testPrepareChunkSizes
+
+testBracket :: IO () -> IO ()
+testBracket =
+  bracket_
+    (mapM_ (createDirectoryIfMissing False) testDirs)
+    (mapM_ removeDirectoryRecursive testDirs)
+  where
+    testDirs = [xftpServerFiles, xftpServerFiles2, senderFiles, recipientFiles]
+
+senderFiles :: FilePath
+senderFiles = "tests/tmp/xftp-sender-files"
+
+recipientFiles :: FilePath
+recipientFiles = "tests/tmp/xftp-recipient-files"
+
+xftpCLI :: [String] -> IO [String]
+xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
+
+testXFTPCLISendReceive :: IO ()
+testXFTPCLISendReceive = withXFTPServer $ do
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` mb 17
+  let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
+                 fdRcv1,
+                 fdRcv2
+               ]
+  testInfoFile fdRcv1 "Recipient"
+  testReceiveFile fdRcv1 "testfile" file
+  testInfoFile fdRcv2 "Recipient"
+  testReceiveFile fdRcv2 "testfile_1" file
+  testInfoFile fdSnd "Sender"
+  xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
+    `shouldThrow` anyException
+  where
+    testInfoFile fd party = do
+      xftpCLI ["info", fd]
+        `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
+    testReceiveFile fd fileName file = do
+      progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
+      progress `shouldSatisfy` downloadProgress fileName
+      recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
+      LB.readFile (recipientFiles </> fileName) `shouldReturn` file
+
+testXFTPCLISendReceive2servers :: IO ()
+testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` mb 17
+  let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
+                 fdRcv1,
+                 fdRcv2
+               ]
+  testReceiveFile fdRcv1 "testfile" file
+  testReceiveFile fdRcv2 "testfile_1" file
+  where
+    testReceiveFile fd fileName file = do
+      partyStr : sizeStr : srvStr : srvs <- xftpCLI ["info", fd]
+      partyStr `shouldContain` "Recipient file description"
+      sizeStr `shouldBe` "File download size: 18mb"
+      srvStr `shouldBe` "File server(s):"
+      case srvs of
+        [srv1] -> any (`isInfixOf` srv1) [testXFTPServerStr, testXFTPServerStr2] `shouldBe` True
+        [srv1, srv2] -> do
+          srv1 `shouldContain` testXFTPServerStr
+          srv2 `shouldContain` testXFTPServerStr2
+        _ -> print srvs >> error "more than 2 servers returned"
+      progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
+      progress `shouldSatisfy` downloadProgress fileName
+      recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
+      LB.readFile (recipientFiles </> fileName) `shouldReturn` file
+
+testXFTPCLIDelete :: IO ()
+testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` mb 17
+  let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
+                 fdRcv1,
+                 fdRcv2
+               ]
+  xftpCLI ["del", fdRcv1]
+    `shouldThrow` anyException
+  progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"]
+  progress1 `shouldSatisfy` downloadProgress "testfile"
+  recvResult `shouldBe` ["File description " <> fdRcv1 <> " is deleted."]
+  LB.readFile (recipientFiles </> "testfile") `shouldReturn` file
+  fs1 <- listDirectory xftpServerFiles
+  fs2 <- listDirectory xftpServerFiles2
+  length fs1 + length fs2 `shouldBe` 6
+  xftpCLI ["del", fdSnd, "-y"]
+    `shouldReturn` ["File deleted!            \r", "File description " <> fdSnd <> " is deleted."]
+  listDirectory xftpServerFiles >>= (`shouldBe` [])
+  listDirectory xftpServerFiles2 >>= (`shouldBe` [])
+  xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
+    `shouldThrow` anyException
+
+testPrepareChunkSizes :: IO ()
+testPrepareChunkSizes = do
+  prepareChunkSizes (mb 9 + kb 256) `shouldBe` [mb 4, mb 4, mb 1, mb 1]
+  prepareChunkSizes (mb 9) `shouldBe` [mb 4, mb 4, mb 1]
+  prepareChunkSizes (mb 7 + 1) `shouldBe` [mb 4, mb 4]
+  prepareChunkSizes (mb 7) `shouldBe` [mb 4] <> r3 (mb 1)
+  prepareChunkSizes (mb 3 + 1) `shouldBe` [mb 4]
+  prepareChunkSizes (mb 3) `shouldBe` r3 (mb 1)
+  prepareChunkSizes (mb 2 + 3 * kb 256 + 1) `shouldBe` r3 (mb 1)
+  prepareChunkSizes (mb 2 + 3 * kb 256) `shouldBe` [mb 1, mb 1] <> r3 (kb 256)
+  prepareChunkSizes (mb 2 + 1) `shouldBe` [mb 1, mb 1, kb 256]
+  prepareChunkSizes (3 * kb 256 + 1) `shouldBe` [mb 1]
+  prepareChunkSizes (3 * kb 256) `shouldBe` r3 (kb 256)
+  prepareChunkSizes 1 `shouldBe` [kb 256]
+  where
+    r3 = replicate 3
+
+uploadProgress :: String -> Bool
+uploadProgress s =
+  "Encrypting file..." `isPrefixOf` s
+    && "Uploading file..." `isInfixOf` s
+    && "File uploaded!" `isInfixOf` s
+
+downloadProgress :: FilePath -> String -> Bool
+downloadProgress fileName s =
+  "Downloading file..." `isPrefixOf` s
+    && "Decrypting file..." `isInfixOf` s
+    && ("File downloaded: " <> recipientFiles </> fileName <> "\r") `isSuffixOf` s

tests/XFTPClient.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module XFTPClient where
+
+import Control.Concurrent (ThreadId)
+import Data.String (fromString)
+import Network.Socket (ServiceName)
+import SMPClient (serverBracket)
+import Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Server (runXFTPServerBlocking)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
+import Simplex.Messaging.Protocol (XFTPServer)
+import Test.Hspec
+
+xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
+xftpTest test = runXFTPTest test `shouldReturn` ()
+
+xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> Expectation
+xftpTestN n test = runXFTPTestN n test `shouldReturn` ()
+
+xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> Expectation
+xftpTest2 test = xftpTestN 2 _test
+  where
+    _test [h1, h2] = test h1 h2
+    _test _ = error "expected 2 handles"
+
+runXFTPTest :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
+runXFTPTest test = withXFTPServer $ testXFTPClient test
+
+runXFTPTestN :: forall a. HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO a) -> IO a
+runXFTPTestN nClients test = withXFTPServer $ run nClients []
+  where
+    run :: Int -> [XFTPClient] -> IO a
+    run 0 hs = test hs
+    run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
+
+withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
+withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
+
+withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
+withXFTPServerCfg cfg =
+  serverBracket
+    (`runXFTPServerBlocking` cfg)
+    (pure ())
+
+withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
+withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
+
+withXFTPServer :: IO a -> IO a
+withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
+
+withXFTPServer2 :: IO a -> IO a
+withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const
+
+xftpTestPort :: ServiceName
+xftpTestPort = "7000"
+
+xftpTestPort2 :: ServiceName
+xftpTestPort2 = "7001"
+
+testXFTPServer :: XFTPServer
+testXFTPServer = fromString testXFTPServerStr
+
+testXFTPServerStr :: String
+testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000"
+
+testXFTPServerStr2 :: String
+testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"
+
+xftpServerFiles :: FilePath
+xftpServerFiles = "tests/tmp/xftp-server-files"
+
+xftpServerFiles2 :: FilePath
+xftpServerFiles2 = "tests/tmp/xftp-server-files2"
+
+testXFTPLogFile :: FilePath
+testXFTPLogFile = "tests/tmp/xftp-server-store.log"
+
+testXFTPStatsBackupFile :: FilePath
+testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
+
+testXFTPServerConfig :: XFTPServerConfig
+testXFTPServerConfig =
+  XFTPServerConfig
+    { xftpPort = xftpTestPort,
+      fileIdSize = 16,
+      storeLogFile = Nothing,
+      filesPath = xftpServerFiles,
+      fileSizeQuota = Nothing,
+      allowedChunkSizes = [kb 128, kb 256, mb 1, mb 4],
+      allowNewFiles = True,
+      newFileBasicAuth = Nothing,
+      fileExpiration = Just defaultFileExpiration,
+      caCertificateFile = "tests/fixtures/ca.crt",
+      privateKeyFile = "tests/fixtures/server.key",
+      certificateFile = "tests/fixtures/server.crt",
+      logStatsInterval = Nothing,
+      logStatsStartTime = 0,
+      serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
+      serverStatsBackupFile = Nothing,
+      logTLSErrors = True
+    }
+
+testXFTPClientConfig :: XFTPClientConfig
+testXFTPClientConfig = defaultXFTPClientConfig
+
+testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
+testXFTPClient client =
+  getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case
+    Right c -> client c
+    Left e -> error $ show e

tests/XFTPServerTests.hs

@@ -0,0 +1,309 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module XFTPServerTests where
+
+import AgentTests.FunctionalAPITests (runRight_)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
+import Control.Exception (SomeException)
+import Control.Monad.Except
+import Crypto.Random (getRandomBytes)
+import qualified Data.ByteString.Base64.URL as B64
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.List (isInfixOf)
+import ServerTests (logSize)
+import Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Description (kb)
+import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..))
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.Messaging.Client (ProtocolClientError (..))
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Protocol (BasicAuth, SenderId)
+import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
+import System.FilePath ((</>))
+import Test.Hspec
+import XFTPClient
+
+xftpServerTests :: Spec
+xftpServerTests =
+  before_ (createDirectoryIfMissing False xftpServerFiles)
+    . after_ (removeDirectoryRecursive xftpServerFiles)
+    . describe "XFTP file chunk delivery"
+    $ do
+      it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
+      it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
+      it "should delete file chunk (1 client)" testFileChunkDelete
+      it "should delete file chunk (2 clients)" testFileChunkDelete2
+      it "should acknowledge file chunk reception (1 client)" testFileChunkAck
+      it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
+      it "should not allow chunks of wrong size" testWrongChunkSize
+      it "should expire chunks after set interval" testFileChunkExpiration
+      it "should not allow uploading chunks after specified storage quota" testFileStorageQuota
+      it "should store file records to log and restore them after server restart" testFileLog
+      describe "XFTP basic auth" $ do
+        --                                               allow FNEW | server auth | clnt auth | success
+        it "prohibited without basic auth" $ testFileBasicAuth True (Just "pwd") Nothing False
+        it "prohibited when auth is incorrect" $ testFileBasicAuth True (Just "pwd") (Just "wrong") False
+        it "prohibited when FNEW disabled" $ testFileBasicAuth False (Just "pwd") (Just "pwd") False
+        it "allowed with correct basic auth" $ testFileBasicAuth True (Just "pwd") (Just "pwd") True
+        it "allowed with auth on server without auth" $ testFileBasicAuth True Nothing (Just "any") True
+
+chSize :: Integral a => a
+chSize = kb 128
+
+testChunkPath :: FilePath
+testChunkPath = "tests/tmp/chunk1"
+
+createTestChunk :: FilePath -> IO ByteString
+createTestChunk fp = do
+  bytes <- getRandomBytes chSize
+  B.writeFile fp bytes
+  pure bytes
+
+readChunk :: SenderId -> IO ByteString
+readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))
+
+testFileChunkDelivery :: Expectation
+testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
+
+testFileChunkDelivery2 :: Expectation
+testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r
+
+runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
+runTestFileChunkDelivery s r = do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = chSize, digest}
+      chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
+  uploadXFTPChunk s spKey sId chunkSpec
+  (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey] Nothing
+  uploadXFTPChunk s spKey sId' chunkSpec
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
+  liftIO $ readChunk sId `shouldReturn` bytes
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
+    `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+
+testFileChunkDelete :: Expectation
+testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
+
+testFileChunkDelete2 :: Expectation
+testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
+
+runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
+runTestFileChunkDelete s r = do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = chSize, digest}
+      chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
+  uploadXFTPChunk s spKey sId chunkSpec
+
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+  deleteXFTPChunk s spKey sId
+  liftIO $
+    readChunk sId
+      `shouldThrow` \(e :: SomeException) -> "openBinaryFile: does not exist" `isInfixOf` show e
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+  deleteXFTPChunk s spKey sId
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+
+testFileChunkAck :: Expectation
+testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c
+
+testFileChunkAck2 :: Expectation
+testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
+
+runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
+runTestFileChunkAck s r = do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = chSize, digest}
+      chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
+  uploadXFTPChunk s spKey sId chunkSpec
+
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+  ackXFTPChunk r rpKey rId
+  liftIO $ readChunk sId `shouldReturn` bytes
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+  ackXFTPChunk r rpKey rId
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+
+testWrongChunkSize :: Expectation
+testWrongChunkSize = xftpTest $ \c -> runRight_ $ do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, _rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  liftIO $ B.writeFile testChunkPath =<< getRandomBytes (kb 96)
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = kb 96, digest}
+  void (createXFTPChunk c spKey file [rcvKey] Nothing)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
+
+testFileChunkExpiration :: Expectation
+testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $
+  \_ -> testXFTPClient $ \c -> runRight_ $ do
+    (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    bytes <- liftIO $ createTestChunk testChunkPath
+    digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+    let file = FileInfo {sndKey, size = chSize, digest}
+        chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+    (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
+    uploadXFTPChunk c spKey sId chunkSpec
+
+    downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+    liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+
+    liftIO $ threadDelay 1000000
+    downloadXFTPChunk c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+    deleteXFTPChunk c spKey sId
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+  where
+    fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
+
+testFileStorageQuota :: Expectation
+testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $
+  \_ -> testXFTPClient $ \c -> runRight_ $ do
+    (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+    bytes <- liftIO $ createTestChunk testChunkPath
+    digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+    let file = FileInfo {sndKey, size = chSize, digest}
+        chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+        download rId = do
+          downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+          liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+    (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
+    uploadXFTPChunk c spKey sId1 chunkSpec
+    download rId1
+    (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing
+    uploadXFTPChunk c spKey sId2 chunkSpec
+    download rId2
+
+    (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing
+    uploadXFTPChunk c spKey sId3 chunkSpec
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
+
+    deleteXFTPChunk c spKey sId1
+    uploadXFTPChunk c spKey sId3 chunkSpec
+    download rId3
+
+testFileLog :: Expectation
+testFileLog = do
+  bytes <- liftIO $ createTestChunk testChunkPath
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+  sIdVar <- newTVarIO ""
+  rIdVar1 <- newTVarIO ""
+  rIdVar2 <- newTVarIO ""
+
+  withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
+    let file = FileInfo {sndKey, size = chSize, digest}
+        chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+    (sId, [rId1, rId2]) <- createXFTPChunk c spKey file [rcvKey1, rcvKey2] Nothing
+    liftIO $
+      atomically $ do
+        writeTVar sIdVar sId
+        writeTVar rIdVar1 rId1
+        writeTVar rIdVar2 rId2
+    uploadXFTPChunk c spKey sId chunkSpec
+    download c rpKey1 rId1 digest bytes
+    download c rpKey2 rId2 digest bytes
+  logSize testXFTPLogFile `shouldReturn` 3
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
+
+  withXFTPServerThreadOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
+    sId <- liftIO $ readTVarIO sIdVar
+    rId1 <- liftIO $ readTVarIO rIdVar1
+    rId2 <- liftIO $ readTVarIO rIdVar2
+    -- recipients and sender get AUTH error because server restarted without log
+    downloadXFTPChunk c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+    downloadXFTPChunk c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+    deleteXFTPChunk c spKey sId
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+
+  withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
+    rId1 <- liftIO $ readTVarIO rIdVar1
+    rId2 <- liftIO $ readTVarIO rIdVar2
+    -- recipient 1 can download, acknowledges - +1 to log
+    download c rpKey1 rId1 digest bytes
+    ackXFTPChunk c rpKey1 rId1
+    -- recipient 2 can download
+    download c rpKey2 rId2 digest bytes
+  logSize testXFTPLogFile `shouldReturn` 4
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
+
+  withXFTPServerStoreLogOn $ \_ -> pure () -- ack is compacted - -1 from log
+  logSize testXFTPLogFile `shouldReturn` 3
+
+  withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
+    sId <- liftIO $ readTVarIO sIdVar
+    rId1 <- liftIO $ readTVarIO rIdVar1
+    rId2 <- liftIO $ readTVarIO rIdVar2
+    -- recipient 1 can't download due to previous acknowledgement
+    download c rpKey1 rId1 digest bytes
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+    -- recipient 2 can download
+    download c rpKey2 rId2 digest bytes
+    -- sender can delete - +1 to log
+    deleteXFTPChunk c spKey sId
+  logSize testXFTPLogFile `shouldReturn` 4
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
+
+  withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start
+  logSize testXFTPLogFile `shouldReturn` 0
+  logSize testXFTPStatsBackupFile `shouldReturn` 11
+
+  removeFile testXFTPLogFile
+  removeFile testXFTPStatsBackupFile
+  where
+    download c rpKey rId digest bytes = do
+      downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+      liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+
+testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO ()
+testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success =
+  withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $
+    \_ -> testXFTPClient $ \c -> runRight_ $ do
+      (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+      (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+      bytes <- liftIO $ createTestChunk testChunkPath
+      digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
+      let file = FileInfo {sndKey, size = chSize, digest}
+          chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+      if success
+        then do
+          (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
+          uploadXFTPChunk c spKey sId chunkSpec
+          downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
+          liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
+        else do
+          void (createXFTPChunk c spKey file [rcvKey] clntAuth)
+            `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))

tests/fixtures/file_description.yaml

@@ -0,0 +1,23 @@
+chunkSize: 8mb
+digest: YWJj
+key: 00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=
+nonce: dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu
+party: recipient
+replicas:
+- chunks:
+  - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
+  - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
+  server: xftp://abc=@example1.com
+- chunks:
+  - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
+  - 4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp:2mb
+  server: xftp://abc=@example2.com
+- chunks:
+  - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  - 4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  server: xftp://abc=@example3.com
+- chunks:
+  - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  server: xftp://abc=@example4.com
+size: 26mb