From 1d78e35688a0cb4965098702735699c3370a190d Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 27 Dec 2022 21:54:02 +0000
Subject: [PATCH 01/71] XFTP modules structure

---
 src/Simplex/FileTransfer.hs                 | 14 ++++++++++++++
 src/Simplex/FileTransfer/Client.hs          |  1 +
 src/Simplex/FileTransfer/Client/Main.hs     |  1 +
 src/Simplex/FileTransfer/Description.hs     |  0
 src/Simplex/FileTransfer/Protocol.hs        |  1 +
 src/Simplex/FileTransfer/Server.hs          |  1 +
 src/Simplex/FileTransfer/Server/Main.hs     |  1 +
 src/Simplex/FileTransfer/Server/Store.hs    |  1 +
 src/Simplex/FileTransfer/Server/StoreLog.hs |  1 +
 9 files changed, 21 insertions(+)
 create mode 100644 src/Simplex/FileTransfer.hs
 create mode 100644 src/Simplex/FileTransfer/Client.hs
 create mode 100644 src/Simplex/FileTransfer/Client/Main.hs
 create mode 100644 src/Simplex/FileTransfer/Description.hs
 create mode 100644 src/Simplex/FileTransfer/Protocol.hs
 create mode 100644 src/Simplex/FileTransfer/Server.hs
 create mode 100644 src/Simplex/FileTransfer/Server/Main.hs
 create mode 100644 src/Simplex/FileTransfer/Server/Store.hs
 create mode 100644 src/Simplex/FileTransfer/Server/StoreLog.hs

diff --git a/src/Simplex/FileTransfer.hs b/src/Simplex/FileTransfer.hs
new file mode 100644
index 000000000..9f648d7ff
--- /dev/null
+++ b/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
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
new file mode 100644
index 000000000..b4ca6fa86
--- /dev/null
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Client where
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
new file mode 100644
index 000000000..467237e02
--- /dev/null
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Client.Main where
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
new file mode 100644
index 000000000..e69de29bb
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
new file mode 100644
index 000000000..c30cb9d27
--- /dev/null
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Protocol where
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
new file mode 100644
index 000000000..a44e6c636
--- /dev/null
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Server where
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
new file mode 100644
index 000000000..d68227fc2
--- /dev/null
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Server.Main where
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
new file mode 100644
index 000000000..af11a1949
--- /dev/null
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Server.Store where
diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs
new file mode 100644
index 000000000..3f082c688
--- /dev/null
+++ b/src/Simplex/FileTransfer/Server/StoreLog.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Server.StoreLog where

From 4b298554301ff1255f633fcf3cfc9d5f7902eaa4 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 29 Dec 2022 18:12:41 +0000
Subject: [PATCH 02/71] core: SimpleX File Transfer protocol type (#587)

* core: File transfer protocol

* Optimization

* Renaming and interfaces

* update response type

* eol

* update type

Co-authored-by: Avently <7953703+avently@users.noreply.github.com>
---
 simplexmq.cabal                         |  21 ++-
 src/Simplex/FileTransfer/Description.hs |   1 +
 src/Simplex/FileTransfer/Protocol.hs    | 236 ++++++++++++++++++++++++
 3 files changed, 252 insertions(+), 6 deletions(-)

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 81143864c..d9f23b64b 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -34,6 +34,15 @@ flag swift
 
 library
   exposed-modules:
+      Simplex.FileTransfer
+      Simplex.FileTransfer.Client
+      Simplex.FileTransfer.Client.Main
+      Simplex.FileTransfer.Description
+      Simplex.FileTransfer.Protocol
+      Simplex.FileTransfer.Server
+      Simplex.FileTransfer.Server.Main
+      Simplex.FileTransfer.Server.Store
+      Simplex.FileTransfer.Server.StoreLog
       Simplex.Messaging.Agent
       Simplex.Messaging.Agent.Client
       Simplex.Messaging.Agent.Env.SQLite
@@ -152,9 +161,9 @@ library
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable ntf-server
   main-is: Main.hs
@@ -214,9 +223,9 @@ executable ntf-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable smp-agent
   main-is: Main.hs
@@ -276,9 +285,9 @@ executable smp-agent
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable smp-server
   main-is: Main.hs
@@ -338,9 +347,9 @@ executable smp-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 test-suite smp-server-test
   type: exitcode-stdio-1.0
@@ -424,6 +433,6 @@ test-suite smp-server-test
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index e69de29bb..3132327b3 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -0,0 +1 @@
+module Simplex.FileTransfer.Description where
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index c30cb9d27..9f36f6206 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -1 +1,237 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
 module Simplex.FileTransfer.Protocol where
+
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Data (type (:~:) (Refl))
+import Data.Int (Int64)
+import Data.Kind (Type)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (isJust, isNothing)
+import Data.Type.Equality (TestEquality (testEquality))
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
+import Simplex.Messaging.Protocol hiding (Cmd, Command (..), CommandTag (..), Recipient, SRecipient, SSender, Sender)
+import Simplex.Messaging.Util ((<$?>))
+
+-- | File protocol clients
+data FileParty = Recipient | Sender
+  deriving (Show)
+
+data SFileParty :: FileParty -> Type where
+  SRecipient :: SFileParty Recipient
+  SSender :: SFileParty Sender
+
+instance TestEquality SFileParty where
+  testEquality SRecipient SRecipient = Just Refl
+  testEquality SSender SSender = Just Refl
+  testEquality _ _ = Nothing
+
+deriving instance Show (SFileParty p)
+
+class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p
+
+instance FilePartyI Recipient where sFileParty = SRecipient
+
+instance FilePartyI Sender where sFileParty = SSender
+
+data FileCommandTag (p :: FileParty) where
+  FNEW_ :: FileCommandTag Sender
+  FADD_ :: FileCommandTag Sender
+  FPUT_ :: FileCommandTag Sender
+  FDEL_ :: FileCommandTag Sender
+  FGET_ :: FileCommandTag Recipient
+  FACK_ :: FileCommandTag Recipient
+  PING_ :: FileCommandTag Recipient
+
+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 SSender FNEW_
+    "FADD" -> Just $ FCT SSender FADD_
+    "FPUT" -> Just $ FCT SSender FPUT_
+    "FDEL" -> Just $ FCT SSender FDEL_
+    "FGET" -> Just $ FCT SRecipient FGET_
+    "FACK" -> Just $ FCT SRecipient FACK_
+    "PING" -> Just $ FCT SRecipient PING_
+    _ -> Nothing
+
+instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
+  decodeTag s = decodeTag s >>= (\(FCT _ t) -> checkParty' t)
+
+instance Protocol FileResponse where
+  type ProtoCommand FileResponse = FileCmd
+  type ProtoType FileResponse = 'PNTF
+  protocolClientHandshake = ntfClientHandshake
+  protocolPing = FileCmd SRecipient PING
+  protocolError = \case
+    FRErr e -> Just e
+    _ -> Nothing
+
+data FileCommand (p :: FileParty) where
+  -- Sender key, recipients keys, chunk size
+  FNEW :: SndPublicVerifyKey -> NonEmpty RcvPublicVerifyKey -> Int64 -> FileCommand Sender
+  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
+  FPUT :: FileCommand Sender
+  FDEL :: FileCommand Sender
+  FGET :: RcvPublicDhKey -> FileCommand Recipient
+  FACK :: FileCommand Recipient
+  PING :: FileCommand Recipient
+
+deriving instance Show (FileCommand p)
+
+data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p)
+
+deriving instance Show FileCmd
+
+instance FilePartyI p => ProtocolEncoding (FileCommand p) where
+  type Tag (FileCommand p) = FileCommandTag p
+  encodeProtocol _v = \case
+    FNEW sKey dhKeys chunkSize -> e (FNEW_, ' ', sKey, dhKeys, chunkSize)
+    FADD dhKeys -> e (FADD_, ' ', dhKeys)
+    FPUT -> e FPUT_
+    FDEL -> e FDEL_
+    FGET dhKey -> e (FGET_, ' ', dhKey)
+    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)
+
+  checkCredentials (sig, _, chunkId, _) cmd = case cmd of
+    -- FNEW must not have signature and chunk ID
+    FNEW {}
+      | isJust sig || not (B.null chunkId) -> Left $ CMD HAS_AUTH
+      | otherwise -> Right cmd
+    -- other client commands must have both signature and queue ID
+    _
+      | isNothing sig || B.null chunkId -> Left $ CMD NO_AUTH
+      | otherwise -> Right cmd
+
+instance ProtocolEncoding FileCmd where
+  type Tag FileCmd = FileCmdTag
+  encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
+
+  protocolP _v = \case
+    FCT SSender tag ->
+      FileCmd SSender <$> case tag of
+        FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
+        FADD_ -> FADD <$> _smpP
+        FPUT_ -> pure FPUT
+        FDEL_ -> pure FDEL
+    FCT SRecipient tag ->
+      FileCmd SRecipient <$> case tag of
+        FGET_ -> FGET <$> _smpP
+        FACK_ -> pure FACK
+        PING_ -> pure PING
+
+  checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
+
+data FileResponseTag
+  = FRChunkIds_
+  | FRRcvIds_
+  | FROk_
+  | FRErr_
+  | FRPong_
+  deriving (Show)
+
+instance Encoding FileResponseTag where
+  smpEncode = \case
+    FRChunkIds_ -> "CHUNK"
+    FRRcvIds_ -> "RIDS"
+    FROk_ -> "OK"
+    FRErr_ -> "ERR"
+    FRPong_ -> "PONG"
+  smpP = messageTagP
+
+instance ProtocolMsgTag FileResponseTag where
+  decodeTag = \case
+    "CHUNK" -> Just FRChunkIds_
+    "RIDS" -> Just FRRcvIds_
+    "OK" -> Just FROk_
+    "ERR" -> Just FRErr_
+    "PONG" -> Just FRPong_
+    _ -> Nothing
+
+data FileResponse
+  = FRChunkIds FileChunkId (NonEmpty FileChunkId)
+  | FRRcvIds (NonEmpty FileChunkId)
+  | FROk
+  | FRErr ErrorType
+  | FRPong
+  deriving (Show)
+
+instance ProtocolEncoding FileResponse where
+  type Tag FileResponse = FileResponseTag
+  encodeProtocol _v = \case
+    FRChunkIds chId rIds -> e (FRChunkIds_, ' ', chId, rIds)
+    FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
+    FROk -> e FROk_
+    FRErr err -> e (FRErr_, ' ', err)
+    FRPong -> e FRPong_
+    where
+      e :: Encoding a => a -> ByteString
+      e = smpEncode
+
+  protocolP _v = \case
+    FRChunkIds_ -> FRChunkIds <$> _smpP <*> smpP
+    FRRcvIds_ -> FRRcvIds <$> _smpP
+    FROk_ -> pure FROk
+    FRErr_ -> FRErr <$> _smpP
+    FRPong_ -> pure FRPong
+
+  checkCredentials (_, _, entId, _) cmd = case cmd of
+    FRChunkIds {} -> 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
+
+type FileChunkId = ByteString
+
+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 "bad command 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

From 7adcbf839feb77d412dd9f48c77402e4cb692d7b Mon Sep 17 00:00:00 2001
From: Stanislav Dmitrenko <7953703+avently@users.noreply.github.com>
Date: Sat, 31 Dec 2022 00:07:35 +0300
Subject: [PATCH 03/71] FileStore (#589)

* FileStore

* Set instead of List

* update

* refactor

* refactor

* sort imports

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Protocol.hs     |   4 +-
 src/Simplex/FileTransfer/Server/Store.hs | 101 ++++++++++++++++++++++-
 2 files changed, 102 insertions(+), 3 deletions(-)

diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 9f36f6206..81da03bbf 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -13,11 +13,11 @@ module Simplex.FileTransfer.Protocol where
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Data (type (:~:) (Refl))
-import Data.Int (Int64)
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (isJust, isNothing)
 import Data.Type.Equality (TestEquality (testEquality))
+import Data.Word (Word32)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
 import Simplex.Messaging.Protocol hiding (Cmd, Command (..), CommandTag (..), Recipient, SRecipient, SSender, Sender)
@@ -97,7 +97,7 @@ instance Protocol FileResponse where
 
 data FileCommand (p :: FileParty) where
   -- Sender key, recipients keys, chunk size
-  FNEW :: SndPublicVerifyKey -> NonEmpty RcvPublicVerifyKey -> Int64 -> FileCommand Sender
+  FNEW :: SndPublicVerifyKey -> NonEmpty RcvPublicVerifyKey -> Word32 -> FileCommand Sender
   FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
   FPUT :: FileCommand Sender
   FDEL :: FileCommand Sender
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index af11a1949..ecd563d46 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -1 +1,100 @@
-module Simplex.FileTransfer.Server.Store where
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.FileTransfer.Server.Store
+  ( FileStore,
+    newQueueStore,
+    addFile,
+    setFilePath,
+    addRecipient,
+    deleteFile,
+    getFile,
+    ackFile,
+  )
+where
+
+import Control.Concurrent.STM
+import Data.Functor (($>))
+import Data.Set (Set)
+import qualified Data.Set as S
+import Simplex.Messaging.Protocol hiding (SParty, SRecipient, SSender)
+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)
+  }
+
+data FileRec = FileRec
+  { senderId :: SenderId,
+    senderKey :: SndPublicVerifyKey,
+    recipientIds :: TVar (Set RecipientId),
+    filepath :: TVar (Maybe FilePath)
+  }
+  deriving (Eq)
+
+newQueueStore :: STM FileStore
+newQueueStore = do
+  files <- TM.empty
+  recipients <- TM.empty
+  pure FileStore {files, recipients}
+
+addFile :: FileStore -> SenderId -> SndPublicVerifyKey -> STM (Either ErrorType ())
+addFile FileStore {files} sId sKey =
+  ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
+    f <- newFileRec sId sKey
+    TM.insert sId f files
+    pure $ Right ()
+
+newFileRec :: SenderId -> SndPublicVerifyKey -> STM FileRec
+newFileRec senderId senderKey = do
+  recipientIds <- newTVar S.empty
+  filepath <- newTVar Nothing
+  pure FileRec {senderId, senderKey, recipientIds, filepath}
+
+setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either ErrorType ())
+setFilePath st sId fPath =
+  withFile st sId $ \FileRec {filepath} ->
+    writeTVar filepath (Just fPath) $> Right ()
+
+addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either ErrorType ())
+addRecipient st@FileStore {recipients} senderId recipient@(rId, _) =
+  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 recipient recipients
+        pure $ Right ()
+
+deleteFile :: FileStore -> SenderId -> STM (Either ErrorType ())
+deleteFile FileStore {files, recipients} senderId = do
+  TM.lookupDelete senderId files >>= \case
+    Just FileRec {recipientIds} -> do
+      readTVar recipientIds >>= mapM_ (`TM.delete` recipients)
+      pure $ Right ()
+    _ -> pure $ Left AUTH
+
+getFile :: FileStore -> SenderId -> STM (Either ErrorType FileRec)
+getFile st sId = withFile st sId $ pure . Right
+
+-- TODO possibly, if acknowledgement of file reception by the last recipient
+-- is going to lead to deleting the file this has to be updated and return some value to delete the actual file
+ackFile :: FileStore -> RecipientId -> STM (Either ErrorType ())
+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 ErrorType a)) -> STM (Either ErrorType a)
+withFile FileStore {files} sId a =
+  TM.lookup sId files >>= \case
+    Just f -> a f
+    _ -> pure $ Left AUTH

From 8dd728e834e9c51bc6706c1782bd114c09fdc18a Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 30 Dec 2022 22:22:07 +0000
Subject: [PATCH 04/71] add XFTP to ProtocolType

---
 src/Simplex/FileTransfer/Protocol.hs | 19 +++++++++++++++----
 src/Simplex/Messaging/Protocol.hs    | 10 +++++++++-
 2 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 81da03bbf..5aba9a58b 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -12,15 +12,26 @@ module Simplex.FileTransfer.Protocol where
 
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Data (type (:~:) (Refl))
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (isJust, isNothing)
-import Data.Type.Equality (TestEquality (testEquality))
+import Data.Type.Equality
 import Data.Word (Word32)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
-import Simplex.Messaging.Protocol hiding (Cmd, Command (..), CommandTag (..), Recipient, SRecipient, SSender, Sender)
+import Simplex.Messaging.Protocol
+  ( CommandError (..),
+    ErrorType (..),
+    Protocol (..),
+    ProtocolEncoding (..),
+    ProtocolMsgTag (..),
+    ProtocolType (..),
+    RcvPublicDhKey,
+    RcvPublicVerifyKey,
+    SndPublicVerifyKey,
+    messageTagP,
+    _smpP,
+  )
 import Simplex.Messaging.Util ((<$?>))
 
 -- | File protocol clients
@@ -88,7 +99,7 @@ instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
 
 instance Protocol FileResponse where
   type ProtoCommand FileResponse = FileCmd
-  type ProtoType FileResponse = 'PNTF
+  type ProtoType FileResponse = 'PXFTP
   protocolClientHandshake = ntfClientHandshake
   protocolPing = FileCmd SRecipient PING
   protocolError = \case
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 11b586f4b..80101e577 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -589,22 +589,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)
 
@@ -622,17 +625,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
@@ -658,6 +664,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,

From 3637d0c610291873f0fbf74c1cf32cfd49b99fe7 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 9 Feb 2023 09:03:34 +0000
Subject: [PATCH 05/71] update protocol/store to include file digest

---
 src/Simplex/FileTransfer/Protocol.hs     | 23 ++++++++++++++------
 src/Simplex/FileTransfer/Server/Store.hs | 27 ++++++++++++------------
 2 files changed, 30 insertions(+), 20 deletions(-)

diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 5aba9a58b..b26fc5fdf 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -107,8 +108,7 @@ instance Protocol FileResponse where
     _ -> Nothing
 
 data FileCommand (p :: FileParty) where
-  -- Sender key, recipients keys, chunk size
-  FNEW :: SndPublicVerifyKey -> NonEmpty RcvPublicVerifyKey -> Word32 -> FileCommand Sender
+  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand Sender
   FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
   FPUT :: FileCommand Sender
   FDEL :: FileCommand Sender
@@ -122,14 +122,21 @@ 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)
+
 instance FilePartyI p => ProtocolEncoding (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
   encodeProtocol _v = \case
-    FNEW sKey dhKeys chunkSize -> e (FNEW_, ' ', sKey, dhKeys, chunkSize)
-    FADD dhKeys -> e (FADD_, ' ', dhKeys)
+    FNEW file rKeys -> e (FNEW_, ' ', file, rKeys)
+    FADD rKeys -> e (FADD_, ' ', rKeys)
     FPUT -> e FPUT_
     FDEL -> e FDEL_
-    FGET dhKey -> e (FGET_, ' ', dhKey)
+    FGET rKey -> e (FGET_, ' ', rKey)
     FACK -> e FACK_
     PING -> e PING_
     where
@@ -155,7 +162,7 @@ instance ProtocolEncoding FileCmd where
   protocolP _v = \case
     FCT SSender tag ->
       FileCmd SSender <$> case tag of
-        FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
+        FNEW_ -> FNEW <$> _smpP <*> smpP
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
@@ -167,6 +174,10 @@ instance ProtocolEncoding FileCmd where
 
   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
+
 data FileResponseTag
   = FRChunkIds_
   | FRRcvIds_
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index ecd563d46..da6eb4331 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -17,6 +17,7 @@ import Control.Concurrent.STM
 import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
+import Simplex.FileTransfer.Protocol (FileInfo)
 import Simplex.Messaging.Protocol hiding (SParty, SRecipient, SSender)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -29,9 +30,9 @@ data FileStore = FileStore
 
 data FileRec = FileRec
   { senderId :: SenderId,
-    senderKey :: SndPublicVerifyKey,
-    recipientIds :: TVar (Set RecipientId),
-    filepath :: TVar (Maybe FilePath)
+    fileInfo :: FileInfo,
+    filePath :: TVar (Maybe FilePath),
+    recipientIds :: TVar (Set RecipientId)
   }
   deriving (Eq)
 
@@ -41,23 +42,23 @@ newQueueStore = do
   recipients <- TM.empty
   pure FileStore {files, recipients}
 
-addFile :: FileStore -> SenderId -> SndPublicVerifyKey -> STM (Either ErrorType ())
-addFile FileStore {files} sId sKey =
+addFile :: FileStore -> SenderId -> FileInfo -> STM (Either ErrorType ())
+addFile FileStore {files} sId fileInfo =
   ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
-    f <- newFileRec sId sKey
+    f <- newFileRec sId fileInfo
     TM.insert sId f files
     pure $ Right ()
 
-newFileRec :: SenderId -> SndPublicVerifyKey -> STM FileRec
-newFileRec senderId senderKey = do
+newFileRec :: SenderId -> FileInfo -> STM FileRec
+newFileRec senderId fileInfo = do
   recipientIds <- newTVar S.empty
-  filepath <- newTVar Nothing
-  pure FileRec {senderId, senderKey, recipientIds, filepath}
+  filePath <- newTVar Nothing
+  pure FileRec {senderId, fileInfo, filePath, recipientIds}
 
 setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either ErrorType ())
 setFilePath st sId fPath =
-  withFile st sId $ \FileRec {filepath} ->
-    writeTVar filepath (Just fPath) $> Right ()
+  withFile st sId $ \FileRec {filePath} ->
+    writeTVar filePath (Just fPath) $> Right ()
 
 addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either ErrorType ())
 addRecipient st@FileStore {recipients} senderId recipient@(rId, _) =
@@ -82,8 +83,6 @@ deleteFile FileStore {files, recipients} senderId = do
 getFile :: FileStore -> SenderId -> STM (Either ErrorType FileRec)
 getFile st sId = withFile st sId $ pure . Right
 
--- TODO possibly, if acknowledgement of file reception by the last recipient
--- is going to lead to deleting the file this has to be updated and return some value to delete the actual file
 ackFile :: FileStore -> RecipientId -> STM (Either ErrorType ())
 ackFile st@FileStore {recipients} recipientId = do
   TM.lookupDelete recipientId recipients >>= \case

From 1523c00bccfcb4b856fcc53ea839785cc971b5f7 Mon Sep 17 00:00:00 2001
From: JRoberts <8711996+jr-simplex@users.noreply.github.com>
Date: Thu, 9 Feb 2023 21:22:58 +0400
Subject: [PATCH 06/71] files: file description types (#631)

---
 package.yaml                            |  1 +
 simplexmq.cabal                         |  7 +-
 src/Simplex/FileTransfer/Description.hs | 92 ++++++++++++++++++++++++-
 src/Simplex/Messaging/Crypto.hs         |  8 +++
 tests/FileDescriptionTests.hs           |  8 +++
 tests/Test.hs                           |  2 +
 tests/fixtures/file_description.yaml    | 15 ++++
 7 files changed, 131 insertions(+), 2 deletions(-)
 create mode 100644 tests/FileDescriptionTests.hs
 create mode 100644 tests/fixtures/file_description.yaml

diff --git a/package.yaml b/package.yaml
index 9af86a4ca..636923529 100644
--- a/package.yaml
+++ b/package.yaml
@@ -71,6 +71,7 @@ dependencies:
   - x509 == 1.7.*
   - x509-store == 1.6.*
   - x509-validation == 1.6.*
+  - yaml == 0.11.*
 
 flags:
   swift:
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 0afb992a9..8b2b1e307 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.0.
+-- This file has been generated from package.yaml by hpack version 0.35.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -165,6 +165,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
@@ -227,6 +228,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
@@ -289,6 +291,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
@@ -351,6 +354,7 @@ 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
@@ -438,6 +442,7 @@ test-suite smp-server-test
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 3132327b3..2c2b8788f 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -1 +1,91 @@
-module Simplex.FileTransfer.Description where
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Simplex.FileTransfer.Description
+  ( FileDescription (..),
+    FileDigest (..),
+    FileChunk (..),
+    FileChunkReplica (..),
+    YAMLFileDescription (..),
+    YAMLFilePart (..),
+  )
+where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
+import Data.Word (Word32)
+import qualified Data.Yaml as Y
+import GHC.Generics (Generic)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+
+data FileDescription = FileDescription
+  { name :: String,
+    size :: Int64,
+    digest :: FileDigest,
+    encKey :: C.Key,
+    iv :: C.IV,
+    chunks :: [FileChunk]
+  }
+  deriving (Show)
+
+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
+
+data FileChunk = FileChunk
+  { chunkNo :: Int,
+    digest :: ByteString,
+    chunkSize :: Word32,
+    replicas :: [FileChunkReplica]
+  }
+  deriving (Show)
+
+data FileChunkReplica = FileChunkReplica
+  { server :: String,
+    rcvId :: ByteString,
+    rcvKey :: C.APrivateSignKey
+  }
+  deriving (Show)
+
+data YAMLFileDescription = YAMLFileDescription
+  { name :: String,
+    size :: Int64,
+    chunkSize :: Word32,
+    digest :: FileDigest,
+    encKey :: C.Key,
+    iv :: C.IV,
+    parts :: [YAMLFilePart]
+  }
+  deriving (Eq, Show, Generic)
+
+instance FromJSON YAMLFileDescription
+
+data YAMLFilePart = YAMLFilePart
+  { server :: String,
+    chunks :: [String]
+  }
+  deriving (Eq, Show, Generic)
+
+instance FromJSON YAMLFilePart
+
+data FilePartChunk = FilePartChunk
+  { chunkNo :: Int,
+    rcvId :: ByteString,
+    rcvKey :: C.APrivateSignKey,
+    digest :: Maybe ByteString,
+    chunkSize :: Maybe Word32
+  }
+  deriving (Show)
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 6b56a7847..da2c4950f 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -742,11 +742,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"
+
 newtype AuthTag = AuthTag {unAuthTag :: AES.AuthTag}
 
 instance Encoding AuthTag where
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
new file mode 100644
index 000000000..6945f9097
--- /dev/null
+++ b/tests/FileDescriptionTests.hs
@@ -0,0 +1,8 @@
+module FileDescriptionTests where
+
+import Test.Hspec
+
+fileDescriptionTests :: Spec
+fileDescriptionTests =
+  describe "file description parsing / rendering" $ do
+    pure ()
diff --git a/tests/Test.hs b/tests/Test.hs
index 287d5b50b..3bf372102 100644
--- a/tests/Test.hs
+++ b/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 (..))
@@ -40,3 +41,4 @@ main = do
         describe "Notifications server" $ ntfServerTests (transport @TLS)
         describe "SMP client agent" $ agentTests (transport @TLS)
         describe "Server CLIs" cliTests
+        describe "File description" fileDescriptionTests
diff --git a/tests/fixtures/file_description.yaml b/tests/fixtures/file_description.yaml
new file mode 100644
index 000000000..da75f6c3e
--- /dev/null
+++ b/tests/fixtures/file_description.yaml
@@ -0,0 +1,15 @@
+name: file.ext
+size: 33200000
+chunk: 8mb
+hash: abc=
+key: abc=
+iv: abc=
+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=:2mb]
+  - server: xftp://abc=@example3.com
+    chunks: [1:abc=:def=, 4:abc=:def=]
+  - server: xftp://abc=@example4.com
+    chunks: [2:abc=:def=, 3:abc=:def=]

From 9775861b6f7439c6c7d641208b6b73d9c20d79b9 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Sun, 12 Feb 2023 19:53:37 +0400
Subject: [PATCH 07/71] files: file description parsing & serialization, tests
 (#633)

* files: file description parsing & serialization, tests

* chunk list

* processFileDescription

* name

* different values

* undo chunk objects to strings

* parser, serializer

* use Either as monad

* refactor

* remove comments

* fix 2 tests

* fix test

* enable all tests

* remove comment

* move

---------

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 simplexmq.cabal                         |   1 +
 src/Simplex/FileTransfer/Description.hs | 213 +++++++++++++++++++++---
 src/Simplex/Messaging/Protocol.hs       |  12 ++
 tests/FileDescriptionTests.hs           | 152 ++++++++++++++++-
 tests/fixtures/file_description.yaml    |  34 ++--
 5 files changed, 376 insertions(+), 36 deletions(-)

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 9b3a59629..386ac9f9c 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -377,6 +377,7 @@ test-suite smp-server-test
       CoreTests.ProtocolErrorTests
       CoreTests.RetryIntervalTests
       CoreTests.VersionRangeTests
+      FileDescriptionTests
       NtfClient
       NtfServerTests
       ServerTests
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 2c2b8788f..a911353c7 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -1,34 +1,56 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
     FileDigest (..),
     FileChunk (..),
     FileChunkReplica (..),
-    YAMLFileDescription (..),
-    YAMLFilePart (..),
+    ChunkReplicaId (..),
+    YAMLFileDescription (..), -- for tests
+    YAMLServerReplicas (..), -- for tests
   )
 where
 
+import Control.Applicative (Alternative ((<|>)), 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.Word (Word32)
 import qualified Data.Yaml as Y
 import GHC.Generics (Generic)
 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 = FileDescription
   { name :: String,
     size :: Int64,
     digest :: FileDigest,
-    encKey :: C.Key,
+    key :: C.Key,
     iv :: C.IV,
+    chunkSize :: Word32,
     chunks :: [FileChunk]
   }
-  deriving (Show)
+  deriving (Eq, Show)
 
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
@@ -47,45 +69,194 @@ instance ToJSON FileDigest where
 
 data FileChunk = FileChunk
   { chunkNo :: Int,
-    digest :: ByteString,
     chunkSize :: Word32,
+    digest :: FileDigest,
     replicas :: [FileChunkReplica]
   }
-  deriving (Show)
+  deriving (Eq, Show)
 
 data FileChunkReplica = FileChunkReplica
-  { server :: String,
-    rcvId :: ByteString,
+  { server :: XFTPServer,
+    rcvId :: ChunkReplicaId,
     rcvKey :: C.APrivateSignKey
   }
-  deriving (Show)
+  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
 
 data YAMLFileDescription = YAMLFileDescription
   { name :: String,
     size :: Int64,
-    chunkSize :: Word32,
     digest :: FileDigest,
-    encKey :: C.Key,
+    key :: C.Key,
     iv :: C.IV,
-    parts :: [YAMLFilePart]
+    chunkSize :: String,
+    replicas :: [YAMLServerReplicas]
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, FromJSON)
 
-instance FromJSON YAMLFileDescription
+instance ToJSON YAMLFileDescription where
+  toJSON = J.genericToJSON J.defaultOptions
+  toEncoding = J.genericToEncoding J.defaultOptions
 
-data YAMLFilePart = YAMLFilePart
-  { server :: String,
+data YAMLServerReplicas = YAMLServerReplicas
+  { server :: XFTPServer,
     chunks :: [String]
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, FromJSON)
 
-instance FromJSON YAMLFilePart
+instance ToJSON YAMLServerReplicas where
+  toJSON = J.genericToJSON J.defaultOptions
+  toEncoding = J.genericToEncoding J.defaultOptions
 
-data FilePartChunk = FilePartChunk
+data FileServerReplica = FileServerReplica
   { chunkNo :: Int,
-    rcvId :: ByteString,
+    server :: XFTPServer,
+    rcvId :: ChunkReplicaId,
     rcvKey :: C.APrivateSignKey,
-    digest :: Maybe ByteString,
+    digest :: Maybe FileDigest,
     chunkSize :: Maybe Word32
   }
   deriving (Show)
+
+instance StrEncoding FileDescription where
+  strEncode = Y.encode . encodeFileDescription
+  strDecode = decodeFileDescription <=< first show . Y.decodeEither'
+  strP = strDecode <$?> A.takeByteString
+
+encodeFileDescription :: FileDescription -> YAMLFileDescription
+encodeFileDescription FileDescription {name, size, digest, key, iv, chunkSize, chunks} =
+  YAMLFileDescription
+    { name,
+      size,
+      digest,
+      key,
+      iv,
+      chunkSize = B.unpack $ encodeChunkSize chunkSize,
+      replicas = encodeFileReplicas chunkSize chunks
+    }
+
+encodeChunkSize :: Word32 -> ByteString
+encodeChunkSize b
+  | b' /= 0 = bshow b
+  | kb' /= 0 = bshow kb <> "kb"
+  | otherwise = bshow mb <> "mb"
+  where
+    (kb, b') = b `divMod` 1024
+    (mb, kb') = kb `divMod` 1024
+
+chunkSizeP :: Parser Word32
+chunkSizeP =
+  ((mb *) <$> A.decimal <* "mb")
+    <|> ((kb *) <$> A.decimal <* "kb")
+    <|> A.decimal
+  where
+    kb = 1024
+    mb = 1024 * kb
+
+encodeFileReplicas :: Word32 -> [FileChunk] -> [YAMLServerReplicas]
+encodeFileReplicas defChunkSize =
+  map encodeServerReplicas
+    . groupBy ((==) `on` server')
+    . sortOn server'
+    . unfoldChunksToReplicas defChunkSize
+  where
+    server' = server :: FileServerReplica -> XFTPServer
+    encodeServerReplicas fs =
+      YAMLServerReplicas
+        { server = server' $ head fs, -- groupBy guarantees that fs is not empty
+          chunks = map (B.unpack . encodeServerReplica) fs
+        }
+
+encodeServerReplica :: FileServerReplica -> ByteString
+encodeServerReplica FileServerReplica {chunkNo, rcvId, rcvKey, digest, chunkSize} =
+  bshow chunkNo
+    <> ":"
+    <> strEncode rcvId
+    <> ":"
+    <> strEncode rcvKey
+    <> maybe "" ((":" <>) . strEncode) digest
+    <> maybe "" ((":" <>) . encodeChunkSize) chunkSize
+
+serverReplicaP :: XFTPServer -> Parser FileServerReplica
+serverReplicaP server = do
+  chunkNo <- A.decimal
+  rcvId <- A.char ':' *> strP
+  rcvKey <- A.char ':' *> strP
+  digest <- optional (A.char ':' *> strP)
+  chunkSize <- optional (A.char ':' *> chunkSizeP)
+  pure FileServerReplica {chunkNo, server, rcvId, rcvKey, digest, chunkSize}
+
+unfoldChunksToReplicas :: 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, rcvId, rcvKey} =
+      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, rcvId, rcvKey, digest = digest', chunkSize = chunkSize'}
+
+decodeFileDescription :: YAMLFileDescription -> Either String FileDescription
+decodeFileDescription YAMLFileDescription {name, size, digest, key, iv, chunkSize, replicas} = do
+  chunkSize' <- parseAll chunkSizeP $ B.pack chunkSize
+  replicas' <- decodeFileParts replicas
+  chunks <- foldReplicasToChunks chunkSize' replicas'
+  pure FileDescription {name, size, digest, key, iv, 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 :: 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 Word32, Map Int FileDigest)
+    foldSizesDigests = foldl' addSizeDigest $ Right (M.empty, M.empty)
+    addSizeDigest :: Either String (Map Int Word32, Map Int FileDigest) -> FileServerReplica -> Either String (Map Int 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 Word32, Map Int FileDigest) -> [FileServerReplica] -> Either String (Map Int FileChunk)
+    foldChunks sd = foldl' (addReplica sd) (Right M.empty)
+    addReplica :: (Map Int 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, rcvId, rcvKey} = do
+      case M.lookup chunkNo cs of
+        Just chunk@FileChunk {replicas} ->
+          let replica = FileChunkReplica {server, rcvId, rcvKey}
+           in Right $ M.insert chunkNo ((chunk :: FileChunk) {replicas = replica : replicas}) cs
+        _ -> do
+          case M.lookup chunkNo md of
+            Just digest' ->
+              let replica = FileChunkReplica {server, rcvId, rcvKey}
+                  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}
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 9ac6e3ebc..bb293a531 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -73,6 +73,8 @@ module Simplex.Messaging.Protocol
     SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    XFTPServer,
+    pattern XFTPServer,
     ProtoServerWithAuth (..),
     BasicAuth (..),
     SrvLoc (..),
@@ -618,6 +620,13 @@ 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 NtfServer #-}
+
 sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
 sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
 {-# INLINE sameSrvAddr' #-}
@@ -734,6 +743,9 @@ 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)
 
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
index 6945f9097..9cfb3876b 100644
--- a/tests/FileDescriptionTests.hs
+++ b/tests/FileDescriptionTests.hs
@@ -1,8 +1,156 @@
+{-# 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 qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import System.Directory (removeFile)
 import Test.Hspec
 
+fileDescPath :: FilePath
+fileDescPath = "tests/fixtures/file_description.yaml"
+
+tmpFileDescPath :: FilePath
+tmpFileDescPath = "tests/tmp/file_description.yaml"
+
+fileDesc :: FileDescription
+fileDesc =
+  FileDescription
+    { name = "file.ext",
+      size = 33200000,
+      digest = FileDigest "abc",
+      key = C.Key "def",
+      iv = C.IV "ghi",
+      chunkSize = 8 * 1024 * 1024,
+      chunks =
+        [ FileChunk
+            { chunkNo = 1,
+              digest = chunkDigest,
+              chunkSize = 8 * 1024 * 1024,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
+                  FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
+                ]
+            },
+          FileChunk
+            { chunkNo = 2,
+              digest = chunkDigest,
+              chunkSize = 8 * 1024 * 1024,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
+                  FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
+                ]
+            },
+          FileChunk
+            { chunkNo = 3,
+              digest = chunkDigest,
+              chunkSize = 8 * 1024 * 1024,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
+                  FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
+                ]
+            },
+          FileChunk
+            { chunkNo = 4,
+              digest = chunkDigest,
+              chunkSize = 2 * 1024 * 1024,
+              replicas =
+                [ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
+                  FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
+                ]
+            }
+        ]
+    }
+  where
+    rcvId = ChunkReplicaId "abc"
+    rcvKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+    chunkDigest = FileDigest "ghi"
+
+yamlFileDesc :: YAMLFileDescription
+yamlFileDesc =
+  YAMLFileDescription
+    { name = "file.ext",
+      size = 33200000,
+      chunkSize = "8mb",
+      digest = FileDigest "abc",
+      key = C.Key "def",
+      iv = C.IV "ghi",
+      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"
+                ]
+            }
+        ]
+    }
+
 fileDescriptionTests :: Spec
 fileDescriptionTests =
-  describe "file description parsing / rendering" $ do
-    pure ()
+  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
+
+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)
diff --git a/tests/fixtures/file_description.yaml b/tests/fixtures/file_description.yaml
index da75f6c3e..42f521d1f 100644
--- a/tests/fixtures/file_description.yaml
+++ b/tests/fixtures/file_description.yaml
@@ -1,15 +1,23 @@
+chunkSize: 8mb
+digest: YWJj
+iv: Z2hp
+key: ZGVm
 name: file.ext
+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: 33200000
-chunk: 8mb
-hash: abc=
-key: abc=
-iv: abc=
-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=:2mb]
-  - server: xftp://abc=@example3.com
-    chunks: [1:abc=:def=, 4:abc=:def=]
-  - server: xftp://abc=@example4.com
-    chunks: [2:abc=:def=, 3:abc=:def=]

From bccef0ba473d15240f46cea935e7eeaf6f9dfb53 Mon Sep 17 00:00:00 2001
From: Stanislav Dmitrenko <7953703+avently@users.noreply.github.com>
Date: Mon, 13 Feb 2023 16:36:02 +0300
Subject: [PATCH 08/71] files: server and client spike - basic upload/download
 (#591)

* Files: main, env, stats, storeLog

* Better + transport

* Executable

* Env

* Update Client.hs, Server.hs, and 4 more files...

* Answer on request

* Delay

* Temp file

* Bypass cert check

* update package.yml, rename

* update store log

* extend HTTP2 transport

* refactor caStore

* HTTP2 body

* update server stats

* file server/client framework

* verify server commands

* process FNEW command, CLI test works

* simple XFTP server test (fails)

* fix test, refactor

* upload chunk works

* receive file chunk in the client

* remove transport handshake

* typo

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* fix names

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 apps/xftp-server/Main.hs                      |  18 ++
 cabal.project                                 |   5 +
 package.yaml                                  |  10 +-
 rfcs/2022-12-26-simplex-file-transfer.md      |   5 +-
 simplexmq.cabal                               |  77 ++++-
 src/Simplex/FileTransfer/Client.hs            | 159 +++++++++++
 src/Simplex/FileTransfer/Protocol.hs          |  86 +++++-
 src/Simplex/FileTransfer/Server.hs            | 267 ++++++++++++++++++
 src/Simplex/FileTransfer/Server/Env.hs        |  67 +++++
 src/Simplex/FileTransfer/Server/Main.hs       | 178 ++++++++++++
 src/Simplex/FileTransfer/Server/Stats.hs      |  93 ++++++
 src/Simplex/FileTransfer/Server/Store.hs      |  27 +-
 src/Simplex/FileTransfer/Server/StoreLog.hs   | 124 +++++++-
 src/Simplex/FileTransfer/Transport.hs         |  42 +++
 src/Simplex/Messaging/Encoding/String.hs      |  12 +-
 .../Notifications/Server/Push/APNS.hs         |   1 +
 src/Simplex/Messaging/Protocol.hs             |   4 +-
 src/Simplex/Messaging/Server.hs               |   4 +-
 src/Simplex/Messaging/Transport.hs            |   4 +-
 src/Simplex/Messaging/Transport/HTTP2.hs      |  17 +-
 .../Messaging/Transport/HTTP2/Client.hs       |  34 ++-
 tests/AgentTests/FunctionalAPITests.hs        |   2 +-
 tests/AgentTests/NotificationTests.hs         |   3 +-
 tests/CLITests.hs                             |  27 ++
 tests/NtfClient.hs                            |  15 +-
 tests/Test.hs                                 |   5 +-
 tests/XFTPClient.hs                           |  61 ++++
 tests/XFTPServerTests.hs                      |  57 ++++
 28 files changed, 1330 insertions(+), 74 deletions(-)
 create mode 100644 apps/xftp-server/Main.hs
 create mode 100644 src/Simplex/FileTransfer/Server/Env.hs
 create mode 100644 src/Simplex/FileTransfer/Server/Stats.hs
 create mode 100644 src/Simplex/FileTransfer/Transport.hs
 create mode 100644 tests/XFTPClient.hs
 create mode 100644 tests/XFTPServerTests.hs

diff --git a/apps/xftp-server/Main.hs b/apps/xftp-server/Main.hs
new file mode 100644
index 000000000..ca3528872
--- /dev/null
+++ b/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
diff --git a/cabal.project b/cabal.project
index 020cc61f7..9ec665d9f 100644
--- a/cabal.project
+++ b/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: 1136bb126636789cec197e5d0bae39aa63c6f9e5
+
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/direct-sqlcipher.git
diff --git a/package.yaml b/package.yaml
index 636923529..9bc66a81b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -42,7 +42,7 @@ dependencies:
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
-  - http2 == 3.0.*
+  - http2 == 4.0.*
   - generic-random >= 1.3 && < 1.5
   - ini == 0.4.1
   - iso8601-time == 0.1.*
@@ -104,6 +104,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
diff --git a/rfcs/2022-12-26-simplex-file-transfer.md b/rfcs/2022-12-26-simplex-file-transfer.md
index a607726fb..9ca7a99d9 100644
--- a/rfcs/2022-12-26-simplex-file-transfer.md
+++ b/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
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 386ac9f9c..2611610c1 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -40,9 +40,12 @@ library
       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.Messaging.Agent
       Simplex.Messaging.Agent.Client
       Simplex.Messaging.Agent.Env.SQLite
@@ -139,7 +142,7 @@ library
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.0.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -201,7 +204,7 @@ executable ntf-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.0.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -264,7 +267,7 @@ executable smp-agent
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.0.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -327,7 +330,7 @@ executable smp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.0.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -360,6 +363,68 @@ executable smp-server
   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.0.*
+    , 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.*
+    , 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.*
+  default-language: Haskell2010
+  if flag(swift)
+    cpp-options: -DswiftJSON
+
 test-suite smp-server-test
   type: exitcode-stdio-1.0
   main-is: Test.hs
@@ -383,6 +448,8 @@ test-suite smp-server-test
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPClient
+      XFTPServerTests
       Paths_simplexmq
   hs-source-dirs:
       tests
@@ -413,7 +480,7 @@ test-suite smp-server-test
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==3.0.*
+    , http2 ==4.0.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , main-tester ==0.2.*
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index b4ca6fa86..c969137fa 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -1 +1,160 @@
+{-# 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 qualified Network.HTTP.Types as N
+import qualified Network.HTTP2.Client as H
+import Simplex.FileTransfer.Protocol
+import Simplex.FileTransfer.Transport (receiveFile, sendFile)
+import Simplex.Messaging.Client
+  ( NetworkConfig (..),
+    ProtocolClientError (..),
+    TransportSession,
+    chooseTransportHost,
+    defaultNetworkConfig,
+    proxyUsername,
+    transportClientConfig,
+  )
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol
+  ( ErrorType (..),
+    ProtocolServer (ProtocolServer),
+    RcvPublicDhKey,
+    RecipientId,
+    SenderId,
+  )
+import Simplex.Messaging.Transport (supportedParameters)
+import Simplex.Messaging.Transport.Client (TransportClientConfig)
+import Simplex.Messaging.Transport.HTTP2
+import Simplex.Messaging.Transport.HTTP2.Client
+import Simplex.Messaging.Util (bshow, liftEitherError)
+import System.IO (IOMode (..), SeekMode (..))
+import UnliftIO.IO (hSeek, withFile)
+
+data XFTPClient = XFTPClient
+  { http2Client :: HTTP2Client,
+    config :: XFTPClientConfig
+  }
+
+data XFTPClientConfig = XFTPClientConfig
+  { networkConfig :: NetworkConfig
+  }
+
+data XFTPChunkBody = XFTPChunkBody
+  { chunkSize :: Int,
+    chunkPart :: Int -> IO ByteString,
+    http2Body :: HTTP2Body
+  }
+
+data XFTPChunkSpec = XFTPChunkSpec
+  { filePath :: FilePath,
+    chunkOffset :: Int64,
+    chunkSize :: Int
+  }
+
+defaultXFTPClientConfig :: XFTPClientConfig
+defaultXFTPClientConfig = XFTPClientConfig {networkConfig = defaultNetworkConfig}
+
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either ProtocolClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfig} disconnected = runExceptT $ do
+  let tcConfig = transportClientConfig networkConfig
+      http2Config = xftpHTTP2Config tcConfig config
+      username = proxyUsername transportSession
+      ProtocolServer _ host port keyHash = srv
+  useHost <- liftEither $ chooseTransportHost networkConfig host
+  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost port (Just keyHash) Nothing http2Config disconnected
+  pure XFTPClient {http2Client, config}
+
+xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig
+xftpHTTP2Config transportConfig XFTPClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} =
+  defaultHTTP2ClientConfig
+    { bodyHeadSize = xftpBlockSize,
+      suportedTLSParams = supportedParameters,
+      connTimeout = tcpConnectTimeout,
+      transportConfig
+    }
+
+xftpClientError :: HTTP2ClientError -> ProtocolClientError
+xftpClientError = \case
+  HCResponseTimeout -> PCEResponseTimeout
+  HCNetworkError -> PCENetworkError
+  HCIOError e -> PCEIOError e
+
+sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT ProtocolClientError IO (FileResponse, HTTP2Body)
+sendXFTPCommand XFTPClient {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
+  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequestDirect http2 req
+  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 -> 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 chunkSize
+      done
+
+createXFTPChunk ::
+  XFTPClient ->
+  C.APrivateSignKey ->
+  FileInfo ->
+  NonEmpty C.APublicVerifyKey ->
+  ExceptT ProtocolClientError IO (SenderId, NonEmpty RecipientId)
+createXFTPChunk c spKey file rsps =
+  sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
+    -- TODO check that body is empty
+    (FRSndIds sId rIds, _body) -> pure (sId, rIds)
+    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT ProtocolClientError IO ()
+uploadXFTPChunk c spKey fId chunkSpec =
+  sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= \case
+    -- TODO check that body is empty
+    (FROk, _body) -> pure ()
+    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> ExceptT ProtocolClientError IO (RcvPublicDhKey, XFTPChunkBody)
+downloadXFTPChunk c rpKey fId rKey =
+  sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case
+    (FRFile sKey, http2Body@HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+      -- TODO atm bodySize is set to 0, so chunkSize will be incorrect
+      Just chunkPart -> do
+        let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body}
+        pure (sKey, chunk)
+      _ -> throwError $ PCEResponseError NO_MSG
+    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT ProtocolClientError IO ()
+receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset, chunkSize} = liftIO $ do
+  withFile filePath WriteMode $ \h -> do
+    hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+    -- TODO chunk decryption
+    void $ receiveFile h chunkPart 0
+
+-- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
+-- FDEL :: FileCommand Sender
+-- FACK :: FileCommand Recipient
+-- PING :: FileCommand Recipient
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index b26fc5fdf..36369d09f 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -11,14 +11,17 @@
 
 module Simplex.FileTransfer.Protocol where
 
+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 (isJust, isNothing)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
+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.Protocol
   ( CommandError (..),
@@ -29,11 +32,29 @@ import Simplex.Messaging.Protocol
     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 ((<$?>))
+import Simplex.Messaging.Version
+
+currentXFTPVersion :: Version
+currentXFTPVersion = 1
+
+xftpBlockSize :: Int
+xftpBlockSize = 16384
 
 -- | File protocol clients
 data FileParty = Recipient | Sender
@@ -129,6 +150,8 @@ data FileInfo = FileInfo
   }
   deriving (Eq, Show)
 
+type XFTPFileId = ByteString
+
 instance FilePartyI p => ProtocolEncoding (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
   encodeProtocol _v = \case
@@ -145,14 +168,18 @@ instance FilePartyI p => ProtocolEncoding (FileCommand p) where
 
   protocolP v tag = (\(FileCmd _ c) -> checkParty c) <$?> protocolP v (FCT (sFileParty @p) tag)
 
-  checkCredentials (sig, _, chunkId, _) cmd = case cmd of
+  checkCredentials (sig, _, fileId, _) cmd = case cmd of
     -- FNEW must not have signature and chunk ID
     FNEW {}
-      | isJust sig || not (B.null chunkId) -> Left $ CMD HAS_AUTH
+      | 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 chunkId -> Left $ CMD NO_AUTH
+      | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
 instance ProtocolEncoding FileCmd where
@@ -178,9 +205,14 @@ 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
-  = FRChunkIds_
+  = FRSndIds_
   | FRRcvIds_
+  | FRFile_
   | FROk_
   | FRErr_
   | FRPong_
@@ -188,8 +220,9 @@ data FileResponseTag
 
 instance Encoding FileResponseTag where
   smpEncode = \case
-    FRChunkIds_ -> "CHUNK"
+    FRSndIds_ -> "SIDS"
     FRRcvIds_ -> "RIDS"
+    FRFile_ -> "FILE"
     FROk_ -> "OK"
     FRErr_ -> "ERR"
     FRPong_ -> "PONG"
@@ -197,16 +230,18 @@ instance Encoding FileResponseTag where
 
 instance ProtocolMsgTag FileResponseTag where
   decodeTag = \case
-    "CHUNK" -> Just FRChunkIds_
+    "SIDS" -> Just FRSndIds_
     "RIDS" -> Just FRRcvIds_
+    "FILE" -> Just FRFile_
     "OK" -> Just FROk_
     "ERR" -> Just FRErr_
     "PONG" -> Just FRPong_
     _ -> Nothing
 
 data FileResponse
-  = FRChunkIds FileChunkId (NonEmpty FileChunkId)
-  | FRRcvIds (NonEmpty FileChunkId)
+  = FRSndIds SenderId (NonEmpty RecipientId)
+  | FRRcvIds (NonEmpty RecipientId)
+  | FRFile RcvPublicDhKey
   | FROk
   | FRErr ErrorType
   | FRPong
@@ -215,8 +250,9 @@ data FileResponse
 instance ProtocolEncoding FileResponse where
   type Tag FileResponse = FileResponseTag
   encodeProtocol _v = \case
-    FRChunkIds chId rIds -> e (FRChunkIds_, ' ', chId, rIds)
+    FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
     FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
+    FRFile rKey -> e (FRFile_, ' ', rKey)
     FROk -> e FROk_
     FRErr err -> e (FRErr_, ' ', err)
     FRPong -> e FRPong_
@@ -225,14 +261,15 @@ instance ProtocolEncoding FileResponse where
       e = smpEncode
 
   protocolP _v = \case
-    FRChunkIds_ -> FRChunkIds <$> _smpP <*> smpP
+    FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
     FRRcvIds_ -> FRRcvIds <$> _smpP
+    FRFile_ -> FRFile <$> _smpP
     FROk_ -> pure FROk
     FRErr_ -> FRErr <$> _smpP
     FRPong_ -> pure FRPong
 
   checkCredentials (_, _, entId, _) cmd = case cmd of
-    FRChunkIds {} -> noEntity
+    FRSndIds {} -> noEntity
     -- ERR response does not always have entity ID
     FRErr _ -> Right cmd
     -- PONG response must not have queue ID
@@ -246,8 +283,6 @@ instance ProtocolEncoding FileResponse where
         | B.null entId = Right cmd
         | otherwise = Left $ CMD HAS_AUTH
 
-type FileChunkId = ByteString
-
 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
@@ -257,3 +292,24 @@ checkParty' :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Maybe (t
 checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Just c
   _ -> Nothing
+
+xftpEncodeTransmission :: ProtocolEncoding 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 c => SessionId -> ByteString -> Either ErrorType (SignedTransmission c)
+xftpDecodeTransmission sessionId t = do
+  t' <- first (const LARGE_MSG) $ C.unPad t
+  case tParse True t' of
+    t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t''
+    _ -> Left BLOCK
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index a44e6c636..26ba37ae5 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -1 +1,268 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
 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 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 qualified Data.List.NonEmpty as L
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
+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.Transport (receiveFile, sendFile)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (CorrId, ErrorType (..), RcvPublicDhKey)
+import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
+import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
+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 : 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
+
+    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} <- 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
+          hPutStrLn h $
+            intercalate
+              ","
+              [ iso8601Show $ utctDay fromTime',
+                show filesCreated',
+                show fileRecipients',
+                show filesUploaded',
+                show filesDeleted',
+                dayCount files,
+                weekCount files,
+                monthCount files,
+                show fileDownloads',
+                show fileDownloadAcks'
+              ]
+        threadDelay interval
+
+-- TODO add client DH secret
+data ServerFile = ServerFile
+  { filePath :: FilePath,
+    fileSize :: Word32,
+    fileDhSecret :: C.DhSecretX25519
+  }
+
+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
+      -- liftIO . sendResponse . H.responseBuilder N.ok200 [] . byteString $
+      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 _ -> send "padding error" -- TODO respond with BLOCK error?
+            Right t -> do
+              send $ byteString t
+              -- TODO chunk encryption
+              forM_ serverFile_ $ \ServerFile {filePath, fileSize, fileDhSecret} -> do
+                withFile filePath ReadMode $ \h -> sendFile h send $ 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 SSender (FNEW file rcps) -> pure $ XFTPReqNew file rcps `verifyWith` sndKey file
+    FileCmd SRecipient 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 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 rcps -> do
+    st <- asks store
+    -- TODO validate body empty
+    -- TODO retry on duplicate IDs?
+    sId <- getFileId
+    rIds <- mapM (const getFileId) rcps
+    r <- runExceptT $ do
+      ExceptT $ atomically $ addFile st sId file
+      forM (L.zip rIds rcps) $ \rcp ->
+        ExceptT $ atomically $ addRecipient st sId rcp
+    noFile $ either FRErr (const $ FRSndIds sId rIds) r
+  XFTPReqCmd fr (FileCmd _ cmd) -> case cmd of
+    FADD _rcps -> noFile FROk
+    FPUT -> (,Nothing) <$> receiveServerFile fr
+    FDEL -> noFile FROk
+    FGET dhKey -> sendServerFile fr dhKey
+    FACK -> noFile FROk
+    -- it should never get to the options 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)
+    receiveServerFile :: FileRec -> M FileResponse
+    receiveServerFile FileRec {senderId, fileInfo, filePath} = case bodyPart of
+      Nothing -> pure $ FRErr QUOTA -- TODO file specific errors?
+      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
+        size' <- liftIO . withFile fPath WriteMode $ \h -> receiveFile h getBody 0
+        if size' == fromIntegral size -- TODO check digest
+          then atomically $ writeTVar filePath (Just fPath) $> FROk
+          else whenM (doesFileExist fPath) (removeFile fPath) $> FRErr QUOTA
+    sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
+    sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
+      readTVarIO filePath >>= \case
+        Just path -> do
+          (sKey, spKey) <- liftIO C.generateKeyPair'
+          let fileDhSecret = C.dh' rKey spKey
+          pure (FRFile sKey, Just ServerFile {filePath = path, fileSize = size, fileDhSecret})
+        _ -> pure (FRErr AUTH, Nothing) -- TODO file-specific errors?
+
+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 :: (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
+          atomically $ setFileServerStats s d
+          renameFile f $ f <> ".bak"
+          logInfo "server stats restored"
+        Left e -> do
+          logInfo $ "error restoring server stats: " <> T.pack e
+          liftIO exitFailure
diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs
new file mode 100644
index 000000000..6a7edd36f
--- /dev/null
+++ b/src/Simplex/FileTransfer/Server/Env.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE StrictData #-}
+
+module Simplex.FileTransfer.Server.Env where
+
+import Control.Monad.IO.Unlift
+import Crypto.Random
+import Data.List.NonEmpty (NonEmpty)
+import Data.Time.Clock (getCurrentTime)
+import Data.X509.Validation (Fingerprint (..))
+import Network.Socket
+import qualified Network.TLS as T
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo)
+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 (RcvPublicVerifyKey)
+import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
+import System.IO (IOMode (..))
+import UnliftIO.STM
+
+data XFTPServerConfig = XFTPServerConfig
+  { xftpPort :: ServiceName,
+    fileIdSize :: Int,
+    storeLogFile :: Maybe FilePath,
+    filesPath :: FilePath,
+    -- 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
+  }
+
+newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv
+newXFTPServerEnv config@XFTPServerConfig {storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
+  idsDrg <- drgNew >>= newTVarIO
+  store <- atomically newFileStore
+  storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
+  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)
+  | XFTPReqCmd FileRec FileCmd
+  | XFTPReqPing
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
index d68227fc2..5f3465698 100644
--- a/src/Simplex/FileTransfer/Server/Main.hs
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -1 +1,179 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
 module Simplex.FileTransfer.Server.Main where
+
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Ini (lookupValue, readIniFile)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Network.Socket (HostName)
+import Options.Applicative
+import Simplex.FileTransfer.Server (runXFTPServer)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import qualified Simplex.Messaging.Crypto as C
+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} = 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\
+               \[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")
+    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
+          cfg@XFTPServerConfig {xftpPort, storeLogFile} = serverConfig
+          srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
+      printServiceInfo serverVersion srv
+      printXFTPConfig xftpPort storeLogFile
+      runXFTPServer cfg
+      where
+        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+        logStats = settingIsOn "STORE_LOG" "log_stats" ini
+        c = combine cfgPath . ($ defaultX509Config)
+        printXFTPConfig xftpPort logFile = do
+          putStrLn $ case logFile of
+            Just f -> "Store log: " <> f
+            _ -> "Store log disabled."
+          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,
+              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
+  }
+  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"
+          )
diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs
new file mode 100644
index 000000000..ff70eec9d
--- /dev/null
+++ b/src/Simplex/FileTransfer/Server/Stats.hs
@@ -0,0 +1,93 @@
+{-# 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.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
+  }
+
+data FileServerStatsData = FileServerStatsData
+  { _fromTime :: UTCTime,
+    _filesCreated :: Int,
+    _fileRecipients :: Int,
+    _filesUploaded :: Int,
+    _filesDeleted :: Int,
+    _filesDownloaded :: PeriodStatsData SenderId,
+    _fileDownloads :: Int,
+    _fileDownloadAcks :: Int
+  }
+
+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
+  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks}
+
+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
+  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks}
+
+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
+
+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=" *> strP <* A.endOfLine
+    _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine
+    _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine
+    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks}
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index da6eb4331..bbacd8335 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -1,9 +1,12 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.FileTransfer.Server.Store
-  ( FileStore,
-    newQueueStore,
+  ( FileStore (..),
+    FileRec (..),
+    newFileStore,
     addFile,
     setFilePath,
     addRecipient,
@@ -17,7 +20,8 @@ import Control.Concurrent.STM
 import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
-import Simplex.FileTransfer.Protocol (FileInfo)
+import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol hiding (SParty, SRecipient, SSender)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -36,8 +40,8 @@ data FileRec = FileRec
   }
   deriving (Eq)
 
-newQueueStore :: STM FileStore
-newQueueStore = do
+newFileStore :: STM FileStore
+newFileStore = do
   files <- TM.empty
   recipients <- TM.empty
   pure FileStore {files, recipients}
@@ -61,7 +65,7 @@ setFilePath st sId fPath =
     writeTVar filePath (Just fPath) $> Right ()
 
 addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either ErrorType ())
-addRecipient st@FileStore {recipients} senderId recipient@(rId, _) =
+addRecipient st@FileStore {recipients} senderId (rId, rKey) =
   withFile st senderId $ \FileRec {recipientIds} -> do
     rIds <- readTVar recipientIds
     mem <- TM.member rId recipients
@@ -69,7 +73,7 @@ addRecipient st@FileStore {recipients} senderId recipient@(rId, _) =
       then pure $ Left DUPLICATE_
       else do
         writeTVar recipientIds $! S.insert rId rIds
-        TM.insert rId recipient recipients
+        TM.insert rId (senderId, rKey) recipients
         pure $ Right ()
 
 deleteFile :: FileStore -> SenderId -> STM (Either ErrorType ())
@@ -80,8 +84,13 @@ deleteFile FileStore {files, recipients} senderId = do
       pure $ Right ()
     _ -> pure $ Left AUTH
 
-getFile :: FileStore -> SenderId -> STM (Either ErrorType FileRec)
-getFile st sId = withFile st sId $ pure . Right
+getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either ErrorType (FileRec, C.APublicVerifyKey))
+getFile st party fId = case party of
+  SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
+  SRecipient ->
+    TM.lookup fId (recipients st) >>= \case
+      Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey)
+      _ -> pure $ Left AUTH
 
 ackFile :: FileStore -> RecipientId -> STM (Either ErrorType ())
 ackFile st@FileStore {recipients} recipientId = do
diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs
index 3f082c688..4258c6784 100644
--- a/src/Simplex/FileTransfer/Server/StoreLog.hs
+++ b/src/Simplex/FileTransfer/Server/StoreLog.hs
@@ -1 +1,123 @@
-module Simplex.FileTransfer.Server.StoreLog where
+{-# 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 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
+  | PutFile SenderId FilePath
+  | AddRecipients SenderId (NonEmpty (RecipientId, RcvPublicVerifyKey))
+  | DeleteFile SenderId
+  | AckFile RecipientId
+
+instance StrEncoding FileStoreLogRecord where
+  strEncode = \case
+    AddFile sId file -> strEncode (Str "FNEW", sId, file)
+    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),
+        "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 -> IO ()
+logAddFile s = logFileStoreRecord s .: AddFile
+
+logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
+logPutFile s = logFileStoreRecord s .: PutFile
+
+logAddRecipients :: StoreLog 'WriteMode -> SenderId -> NonEmpty (RecipientId, RcvPublicVerifyKey) -> 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 -> addFile st sId file
+      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} = do
+      logAddFile s senderId fileInfo
+      (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 (rId, rKey)
+            | otherwise -> Left $ "sender ID for recipient ID " <> bshow rId <> " does not match FileRec"
+          Nothing -> Left $ "recipient ID " <> bshow rId <> " not found"
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
new file mode 100644
index 000000000..15fad7d4a
--- /dev/null
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Transport
+  ( supportedFileServerVRange,
+    sendFile,
+    receiveFile,
+  )
+where
+
+import Control.Monad.Except
+import Data.ByteString.Builder (Builder, byteString)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import GHC.IO.Handle.Internals (ioe_EOF)
+import Simplex.FileTransfer.Protocol (xftpBlockSize)
+import Simplex.Messaging.Version
+import System.IO (Handle)
+
+supportedFileServerVRange :: VersionRange
+supportedFileServerVRange = mkVersionRange 1 1
+
+sendFile :: Handle -> (Builder -> IO ()) -> Int -> IO ()
+sendFile _ _ 0 = pure ()
+sendFile h send sz = do
+  B.hGet h xftpBlockSize >>= \case
+    "" -> when (sz /= 0) ioe_EOF
+    ch -> do
+      let ch' = B.take sz ch -- sz >= xftpBlockSize
+      send (byteString ch')
+      sendFile h send $ sz - B.length ch'
+
+-- TODO instead of receiving the whole file this function should stop at size and return error if file is larger
+receiveFile :: Handle -> (Int -> IO ByteString) -> Int -> IO Int
+receiveFile h receive sz = do
+  ch <- receive xftpBlockSize
+  let chSize = B.length ch
+  if chSize > 0
+    then B.hPut h ch >> receiveFile h receive (sz + chSize)
+    else pure sz
diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs
index 769d591b9..f35251348 100644
--- a/src/Simplex/Messaging/Encoding/String.hs
+++ b/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 FilePath where
+  strEncode = strEncode
+  strDecode = strDecode
+
 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 #-}
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index 5eee63447..32f92c6aa 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -343,6 +343,7 @@ 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
+  -- TODO if HTTP2 client is thread-safe, we can use sendRequestDirect (the tests pass)
   HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req
   let status = H.responseStatus response
       reason' = maybe "" reason $ J.decodeStrict' bodyHead
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index df2a79f0b..6aae56264 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -629,7 +629,7 @@ type XFTPServer = ProtocolServer 'PXFTP
 pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP
 pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash
 
-{-# COMPLETE NtfServer #-}
+{-# COMPLETE XFTPServer #-}
 
 sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
 sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
@@ -1217,7 +1217,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
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index e66da37be..681d073c3 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/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
diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs
index 2042e530e..9df1a127d 100644
--- a/src/Simplex/Messaging/Transport.hs
+++ b/src/Simplex/Messaging/Transport.hs
@@ -303,7 +303,7 @@ transportErrorP =
   "BLOCK" $> TEBadBlock
     <|> "LARGE_MSG" $> TELargeMsg
     <|> "SESSION" $> TEBadSession
-    <|> TEHandshake <$> parseRead1
+    <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
 
 -- | Serialize SMP encrypted transport error.
 serializeTransportError :: TransportError -> ByteString
@@ -311,7 +311,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 ())
diff --git a/src/Simplex/Messaging/Transport/HTTP2.hs b/src/Simplex/Messaging/Transport/HTTP2.hs
index dc023f920..f258f9dc9 100644
--- a/src/Simplex/Messaging/Transport/HTTP2.hs
+++ b/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}
diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs
index c8d74dbc5..53f2f18f4 100644
--- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs
+++ b/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,21 +101,23 @@ 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 ()
@@ -123,8 +129,20 @@ sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req = do
   atomically $ writeTBQueue reqQ (req, resp)
   maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
 
-runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client ()) -> IO ()
+sendRequestDirect :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
+sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req =
+  connTimeout config `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}
+
+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
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index fdf931df0..7856a002f 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -85,7 +85,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
diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs
index 6f4fbb65d..a3abd2242 100644
--- a/tests/AgentTests/NotificationTests.hs
+++ b/tests/AgentTests/NotificationTests.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.NotificationTests where
@@ -464,7 +465,7 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     liftIO $ killThread threadId
     pure (aliceId, bobId)
 
-  runRight_ $ do
+  runRight_ @AgentErrorType $ do
     get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
     get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
 
diff --git a/tests/CLITests.hs b/tests/CLITests.hs
index e18cf1963..44ef4022c 100644
--- a/tests/CLITests.hs
+++ b/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"] <> ["-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
diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs
index d3c10c80e..f0a9a1d47 100644
--- a/tests/NtfClient.hs
+++ b/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
 
diff --git a/tests/Test.hs b/tests/Test.hs
index 3bf372102..45d3afbb0 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -16,6 +16,7 @@ import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
+import XFTPServerTests (xftpServerTests)
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -40,5 +41,7 @@ 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 "Server CLIs" cliTests
-        describe "File description" fileDescriptionTests
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
new file mode 100644
index 000000000..c41a20e1c
--- /dev/null
+++ b/tests/XFTPClient.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module XFTPClient where
+
+import Control.Concurrent (ThreadId)
+import Network.Socket (ServiceName)
+import SMPClient (serverBracket)
+import Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Server (runXFTPServerBlocking)
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import Simplex.Messaging.Protocol (XFTPServer)
+import Test.Hspec
+
+xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
+xftpTest test = runXFTPTest test `shouldReturn` ()
+
+runXFTPTest :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
+runXFTPTest test = withXFTPServer $ testXFTPClient test
+
+withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
+withXFTPServerCfg cfg =
+  serverBracket
+    (`runXFTPServerBlocking` cfg)
+    (pure ())
+
+withXFTPServer :: IO a -> IO a
+withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
+
+xftpTestPort :: ServiceName
+xftpTestPort = "7000"
+
+testXFTPServer :: XFTPServer
+testXFTPServer = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000"
+
+testXFTPServerConfig :: XFTPServerConfig
+testXFTPServerConfig =
+  XFTPServerConfig
+    { xftpPort = xftpTestPort,
+      fileIdSize = 16,
+      storeLogFile = Nothing,
+      filesPath = "tests/xftp-files",
+      caCertificateFile = "tests/fixtures/ca.crt",
+      privateKeyFile = "tests/fixtures/server.key",
+      certificateFile = "tests/fixtures/server.crt",
+      logStatsInterval = Nothing,
+      logStatsStartTime = 0,
+      serverStatsLogFile = "tests/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
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
new file mode 100644
index 000000000..9ba61c51a
--- /dev/null
+++ b/tests/XFTPServerTests.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module XFTPServerTests where
+
+import AgentTests.FunctionalAPITests (runRight_)
+import Control.Monad.IO.Class (liftIO)
+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 Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Protocol (FileInfo (..))
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol (SenderId)
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
+import System.IO (IOMode (..), withFile)
+import Test.Hspec
+import XFTPClient
+
+xftpServerTests :: Spec
+xftpServerTests =
+  before_ (createDirectoryIfMissing False "tests/xftp-files")
+    . after_ (removeDirectoryRecursive "tests/xftp-files")
+    $ do
+      describe "XFTP file chunk delivery" testFileChunkDelivery
+
+chSize :: Num n => n
+chSize = 256 * 1024
+
+createTestChunk :: FilePath -> IO ByteString
+createTestChunk fp = do
+  bytes <- getRandomBytes chSize
+  withFile fp WriteMode $ \h -> B.hPut h bytes
+  pure bytes
+
+readChunk :: SenderId -> IO ByteString
+readChunk sId = B.readFile ("tests/xftp-files/" <> B.unpack (B64.encode sId))
+
+testFileChunkDelivery :: Spec
+testFileChunkDelivery =
+  it "should create, upload and receive file chunk" $ do
+    (sndKey, spKey) <- C.generateSignatureKeyPair C.SEd25519
+    (rcvKey, rpKey) <- C.generateSignatureKeyPair C.SEd25519
+    (rDhKey, _rpDhKey) <- C.generateKeyPair'
+    bytes <- createTestChunk "tests/tmp/chunk1"
+    xftpTest $ \c -> runRight_ $ do
+      let file = FileInfo {sndKey, size = chSize, digest = "abc="}
+      (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey]
+      uploadXFTPChunk c spKey sId $ XFTPChunkSpec {filePath = "tests/tmp/chunk1", chunkOffset = 0, chunkSize = chSize}
+      liftIO $ readChunk sId `shouldReturn` bytes
+      (_sDhKey, chunkBody) <- downloadXFTPChunk c rpKey rId rDhKey
+      receiveXFTPChunk chunkBody XFTPChunkSpec {filePath = "tests/tmp/received_chunk1", chunkOffset = 0, chunkSize = chSize}
+      liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+      pure ()

From 4e8657097c436213301bb29d34b52ebc311eab61 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 16 Feb 2023 14:06:03 +0400
Subject: [PATCH 09/71] xftp: cli client draft (#635)

* xftp: cli client draft

* more stubs

* compiles

* hash, app

* options parsers, random

* tmp

* xftp CLI client agent, simplify CLI command syntax

* only allow argument as a second parameter

* pivot signature draft

* receive file

* pivot sent chunks to recipients

* encryptFile - temp, chunks, specs

* send (upload) file and save file descriptions

* refactor, remove encrypted file

* save file size in description as string

* include filename inside padded encrypted file

* call chunk uploads concurrently, using queueing in HTTP2 as library client does not support concurrent streaming uploads

* download file (does not work yet)

* add digests to sent chunks

* fix recv - save file using AppendMode

* encrypt/decrypt sent file with secretbox

* remove print

* fix file description parsing in tests

* fix test

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 apps/xftp/Main.hs                        |   6 +
 package.yaml                             |   9 +
 simplexmq.cabal                          |  67 ++++
 src/Simplex/FileTransfer/Client.hs       |   9 +-
 src/Simplex/FileTransfer/Client/Agent.hs | 116 +++++++
 src/Simplex/FileTransfer/Client/Main.hs  | 383 ++++++++++++++++++++++-
 src/Simplex/FileTransfer/Description.hs  | 111 ++++---
 src/Simplex/Messaging/Agent/Client.hs    |   7 -
 src/Simplex/Messaging/Client.hs          |   8 +
 src/Simplex/Messaging/Crypto.hs          |  29 +-
 tests/FileDescriptionTests.hs            |  50 +--
 tests/fixtures/file_description.yaml     |   7 +-
 12 files changed, 711 insertions(+), 91 deletions(-)
 create mode 100644 apps/xftp/Main.hs
 create mode 100644 src/Simplex/FileTransfer/Client/Agent.hs

diff --git a/apps/xftp/Main.hs b/apps/xftp/Main.hs
new file mode 100644
index 000000000..c96a664c9
--- /dev/null
+++ b/apps/xftp/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Simplex.FileTransfer.Client.Main
+
+main :: IO ()
+main = xftpClientCLI
diff --git a/package.yaml b/package.yaml
index 2374d1984..dbb66441b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -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.*
@@ -120,6 +121,14 @@ executables:
     ghc-options:
       - -threaded
 
+  xftp:
+    source-dirs: apps/xftp
+    main: Main.hs
+    dependencies:
+      - simplexmq
+    ghc-options:
+      - -threaded
+
 tests:
   simplexmq-test:
     source-dirs: tests
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 5e034019d..9ff4070e9 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -36,6 +36,7 @@ library
   exposed-modules:
       Simplex.FileTransfer
       Simplex.FileTransfer.Client
+      Simplex.FileTransfer.Client.Agent
       Simplex.FileTransfer.Client.Main
       Simplex.FileTransfer.Description
       Simplex.FileTransfer.Protocol
@@ -158,6 +159,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.*
@@ -364,6 +366,70 @@ executable smp-server
   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.0.*
+    , 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:
@@ -422,6 +488,7 @@ executable xftp-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index c969137fa..e0528e0ce 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -65,6 +65,7 @@ data XFTPChunkSpec = XFTPChunkSpec
     chunkOffset :: Int64,
     chunkSize :: Int
   }
+  deriving (Show)
 
 defaultXFTPClientConfig :: XFTPClientConfig
 defaultXFTPClientConfig = XFTPClientConfig {networkConfig = defaultNetworkConfig}
@@ -100,7 +101,7 @@ sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fI
     liftEither . first PCETransportError $
       xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
   let req = H.requestStreaming N.methodPost "/" [] $ streamBody t
-  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequestDirect http2 req
+  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req
   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
@@ -148,9 +149,9 @@ downloadXFTPChunk c rpKey fId rKey =
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
 receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT ProtocolClientError IO ()
-receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset, chunkSize} = liftIO $ do
-  withFile filePath WriteMode $ \h -> do
-    hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset} = liftIO $ do
+  withFile filePath AppendMode $ \h -> do
+    -- hSeek h AbsoluteSeek $ fromIntegral chunkOffset
     -- TODO chunk decryption
     void $ receiveFile h chunkPart 0
 
diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs
new file mode 100644
index 000000000..63cc77ed0
--- /dev/null
+++ b/src/Simplex/FileTransfer/Client/Agent.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# 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 (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 ProtocolClientError
+  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 :: 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 {networkConfig = 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) $ void . tryConnectClient
+
+showServer :: XFTPServer -> Text
+showServer ProtocolServer {host, port} =
+  decodeUtf8 $ strEncode host <> B.pack (if null port then "" else ':' : port)
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 467237e02..4a7504211 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -1 +1,382 @@
-module Simplex.FileTransfer.Client.Main where
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Client.Main (xftpClientCLI) where
+
+import Control.Monad
+import Control.Monad.Except
+import Crypto.Random (getRandomBytes)
+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 qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Data.List (foldl', sortOn)
+import qualified Data.List.NonEmpty as L
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Word (Word32)
+import Options.Applicative
+import Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Client.Agent
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileInfo (..))
+import Simplex.Messaging.Agent.Lock
+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.Protocol (SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer)
+import Simplex.Messaging.Server.CLI (getCliCommand')
+import Simplex.Messaging.Util (ifM, whenM)
+import System.Exit (exitFailure)
+import System.FilePath (splitExtensions, splitFileName, (</>))
+import System.IO.Temp (getCanonicalTemporaryDirectory)
+import UnliftIO
+import UnliftIO.Directory
+
+xftpClientVersion :: String
+xftpClientVersion = "0.1.0"
+
+defaultChunkSize :: Word32
+defaultChunkSize = 8 * mb
+
+smallChunkSize :: Word32
+smallChunkSize = 1 * mb
+
+fileSizeLen :: Int64
+fileSizeLen = 8
+
+cbAuthTagLen :: Int64
+cbAuthTagLen = fromIntegral C.cbAuthTagSize
+
+mb :: Num a => a
+mb = 1024 * 1024
+
+newtype CLIError = CLIError String
+  deriving (Eq, Show, Exception)
+
+data CliCommand
+  = SendFile SendOptions
+  | ReceiveFile ReceiveOptions
+  | RandomFile RandomFileOptions
+
+data SendOptions = SendOptions
+  { filePath :: FilePath,
+    outputDir :: Maybe FilePath,
+    numRecipients :: Int,
+    retryCount :: Int,
+    tempPath :: Maybe FilePath
+  }
+  deriving (Show)
+
+data ReceiveOptions = ReceiveOptions
+  { fileDescription :: FilePath,
+    filePath :: Maybe FilePath,
+    retryCount :: Int,
+    tempPath :: Maybe FilePath
+  }
+  deriving (Show)
+
+data RandomFileOptions = RandomFileOptions
+  { filePath :: FilePath,
+    fileSize :: FileSize Int
+  }
+  deriving (Show)
+
+defaultRetryCount :: Int
+defaultRetryCount = 3
+
+xftpServer :: XFTPServer
+xftpServer = "xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"
+
+cliCommandP :: Parser CliCommand
+cliCommandP =
+  hsubparser
+    ( command "send" (info (SendFile <$> sendP) (progDesc "Send file"))
+        <> command "recv" (info (ReceiveFile <$> receiveP) (progDesc "Receive file"))
+        <> command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size"))
+    )
+  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)
+        <*> retries
+        <*> temp
+    receiveP :: Parser ReceiveOptions
+    receiveP =
+      ReceiveOptions
+        <$> argument str (metavar "FILE" <> help "File description file")
+        <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
+        <*> retries
+        <*> temp
+    randomP :: Parser RandomFileOptions
+    randomP =
+      RandomFileOptions
+        <$> argument str (metavar "FILE" <> help "Path to save file")
+        <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb)")
+    strDec = eitherReader $ strDecode . B.pack
+    retries = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
+    temp = optional (strOption $ long "temp" <> metavar "TEMP" <> help "Directory for temporary encrypted file (default: system temp directory)")
+
+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,
+    rcvId :: ChunkReplicaId,
+    rcvKey :: C.APrivateSignKey,
+    digest :: FileDigest,
+    chunkSize :: FileSize Word32
+  }
+
+xftpClientCLI :: IO ()
+xftpClientCLI =
+  getCliCommand' cliCommandP clientVersion >>= \case
+    SendFile opts -> runE $ cliSendFile opts
+    ReceiveFile opts -> runE $ cliReceiveFile opts
+    RandomFile opts -> cliRandomFile opts
+  where
+    clientVersion = "SimpleX XFTP client v" <> xftpClientVersion
+
+runE :: ExceptT CLIError IO () -> IO ()
+runE a =
+  runExceptT a >>= \case
+    Left (CLIError e) -> putStrLn e >> exitFailure
+    _ -> pure ()
+
+-- 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}
+
+cliSendFile :: SendOptions -> ExceptT CLIError IO ()
+cliSendFile SendOptions {filePath, outputDir, numRecipients, retryCount, tempPath} = do
+  let (_, fileName) = splitFileName filePath
+  (encPath, fd, chunkSpecs) <- encryptFile fileName
+  sentChunks <- uploadFile chunkSpecs
+  whenM (doesFileExist encPath) $ removeFile encPath
+  -- TODO if only small chunks, use different default size
+  liftIO $ writeFileDescriptions fileName $ createFileDescriptions fd sentChunks
+  where
+    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription, [XFTPChunkSpec])
+    encryptFile fileName = do
+      encPath <- getEncPath tempPath "xftp"
+      key <- liftIO C.randomSbKey
+      nonce <- liftIO C.randomCbNonce
+      fileSize <- fromInteger <$> getFileSize filePath
+      let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
+          fileSize' = fromIntegral (B.length fileHdr) + fileSize
+          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + cbAuthTagLen
+          paddedSize = fromIntegral $ sum chunkSizes
+      encrypt fileHdr key nonce fileSize' paddedSize encPath
+      digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
+      let chunkSpecs = prepareChunkSpecs encPath chunkSizes
+          fd = FileDescription {size = FileSize paddedSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
+      pure (encPath, fd, chunkSpecs)
+      where
+        encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
+        encrypt fileHdr key nonce fileSize' paddedSize encFile = do
+          f <- liftIO $ LB.readFile filePath
+          let f' = LB.fromStrict fileHdr <> f
+          c <- liftEither $ first (CLIError . show) $ LC.sbEncrypt key nonce f' fileSize' $ paddedSize - cbAuthTagLen
+          liftIO $ LB.writeFile encFile c
+    -- let padSize = paddedSize - fileSize - fromIntegral (B.length fileHdr)
+    -- when (padSize > 0) . LB.hPut h $ LB.replicate padSize '#'
+    uploadFile :: [XFTPChunkSpec] -> ExceptT CLIError IO [SentFileChunk]
+    uploadFile chunks = do
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      -- TODO shuffle chunks
+      sentChunks <- pooledForConcurrentlyN 32 (zip [1 ..] chunks) $ uploadFileChunk a
+      -- TODO unshuffle chunks
+      pure $ map snd sentChunks
+      where
+        retries = withRetry retryCount
+        uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
+        uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
+          (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+          rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
+          chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
+          -- TODO choose server randomly
+          c <- retries $ withExceptT (CLIError . show) $ getXFTPServerClient a xftpServer
+          (sndId, rIds) <- retries $ withExceptT (CLIError . show) $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
+          retries $ withExceptT (CLIError . show) $ uploadXFTPChunk c spKey sndId chunkSpec
+          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.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
+            pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
+
+    -- M chunks, R replicas, N recipients
+    -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
+    -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
+    createFileDescriptions :: FileDescription -> [SentFileChunk] -> [FileDescription]
+    createFileDescriptions fd sentChunks = map (\chunks -> (fd :: FileDescription) {chunks}) rcvChunks
+      where
+        rcvReplicas :: [SentRecipientReplica]
+        rcvReplicas =
+          concatMap
+            ( \SentFileChunk {chunkNo, digest, chunkSize, replicas} ->
+                concatMap
+                  ( \SentFileChunkReplica {server, recipients} ->
+                      zipWith (\rcvNo (rcvId, rcvKey) -> SentRecipientReplica {chunkNo, server, rcvNo, rcvId, rcvKey, 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, rcvId, rcvKey, 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, rcvId, rcvKey}
+    writeFileDescriptions :: String -> [FileDescription] -> IO ()
+    writeFileDescriptions fileName fds = do
+      outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
+      createDirectoryIfMissing True outDir
+      forM_ (zip [1 ..] fds) $ \(i, fd) -> do
+        let fdPath = outDir </> ("rcv" <> show i <> ".xftp")
+        B.writeFile fdPath $ strEncode fd
+
+cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
+cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} = do
+  fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile fileDescription
+  ValidFileDescription FileDescription {size, key, nonce, chunks} <- liftEither . first CLIError $ validateFileDescription fd
+  encPath <- getEncPath tempPath "xftp"
+  -- withFile encPath WriteMode $ \h -> do
+  --   liftIO $ LB.hPut h $ LB.replicate (unFileSize size) '#'
+  a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+  writeLock <- atomically createLock
+  let chunkSizes = prepareChunkSizes $ unFileSize size
+      chunkSpecs = prepareChunkSpecs encPath chunkSizes
+  -- chunks have to be ordered because of AppendMode
+  forM_ (zip chunkSpecs chunks) $ \(chunkSpec, chunk) -> do
+    downloadFileChunk a writeLock chunk chunkSpec
+  -- verify file digest
+  decryptFile encPath key nonce
+  whenM (doesFileExist encPath) $ removeFile encPath
+  where
+    downloadFileChunk :: XFTPClientAgent -> Lock -> FileChunk -> XFTPChunkSpec -> ExceptT CLIError IO ()
+    downloadFileChunk a writeLock FileChunk {replicas = replica : _} chunkSpec = do
+      let FileChunkReplica {server, rcvId, rcvKey} = replica
+      c <- withRetry retryCount $ withExceptT (CLIError . show) $ getXFTPServerClient a server
+      (rKey, rpKey) <- liftIO C.generateKeyPair'
+      (sKey, body) <- withRetry retryCount $ withExceptT (CLIError . show) $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey
+      -- download and decrypt (DH) chunk from server using XFTPClient
+      -- verify chunk digest - in the client
+      -- save to correct location in file - also in the client
+      withRetry retryCount $ withExceptT (CLIError . show) $ withLock writeLock "save" $ receiveXFTPChunk body chunkSpec
+    downloadFileChunk _ _ _ _ = pure ()
+    decryptFile :: FilePath -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO ()
+    decryptFile encPath key nonce = do
+      f <- liftIO $ LB.readFile encPath
+      f' <- liftEither $ first (CLIError . show) $ LC.sbDecrypt key nonce f
+      let (fileHdr, f'') = LB.splitAt 1024 f'
+      -- withFile encPath ReadMode $ \r -> do
+      --   fileHdr <- liftIO $ B.hGet r 1024
+      case A.parse smpP $ LB.toStrict fileHdr of
+        A.Fail _ _ e -> throwError $ CLIError $ "Invalid file header: " <> e
+        A.Partial _ -> throwError $ CLIError "Invalid file header"
+        A.Done rest FileHeader {fileName} -> do
+          path <- getFilePath fileName
+          liftIO $ LB.writeFile path $ LB.fromStrict rest <> f''
+    getFilePath :: String -> ExceptT CLIError IO FilePath
+    getFilePath name =
+      case filePath of
+        Just path ->
+          ifM (doesDirectoryExist path) (uniqueCombine path name) $
+            ifM (doesFileExist path) (throwError $ CLIError "File already exists") (pure path)
+        _ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
+
+prepareChunkSizes :: Int64 -> [Word32]
+prepareChunkSizes 0 = []
+prepareChunkSizes size
+  | size >= defSz = replicate (fromIntegral n1) defaultChunkSize <> prepareChunkSizes remSz
+  | size > defSz `div` 2 = [defaultChunkSize]
+  | otherwise = replicate (fromIntegral n2') smallChunkSize
+  where
+    (n1, remSz) = size `divMod` defSz
+    n2' = let (n2, remSz2) = (size `divMod` fromIntegral smallChunkSize) in if remSz2 == 0 then n2 else n2 + 1
+    defSz = fromIntegral defaultChunkSize :: Int64
+
+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
+
+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)
+
+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` \_ -> withRetry (n - 1) a
+
+cliRandomFile :: RandomFileOptions -> IO ()
+cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} =
+  withFile filePath WriteMode (`saveRandomFile` size)
+  where
+    saveRandomFile h sz = do
+      bytes <- getRandomBytes $ min mb sz
+      B.hPut h bytes
+      when (sz > mb) $ saveRandomFile h (sz - mb)
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index a911353c7..8bdc4f300 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -4,20 +4,25 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
+    ValidFileDescription,
+    pattern ValidFileDescription,
     FileDigest (..),
     FileChunk (..),
     FileChunkReplica (..),
+    FileSize (..),
     ChunkReplicaId (..),
     YAMLFileDescription (..), -- for tests
     YAMLServerReplicas (..), -- for tests
+    validateFileDescription,
   )
 where
 
-import Control.Applicative (Alternative ((<|>)), optional)
+import Control.Applicative (optional)
 import Control.Monad ((<=<))
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
@@ -42,16 +47,20 @@ import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Util (bshow, (<$?>))
 
 data FileDescription = FileDescription
-  { name :: String,
-    size :: Int64,
+  { size :: FileSize Int64,
     digest :: FileDigest,
-    key :: C.Key,
-    iv :: C.IV,
-    chunkSize :: Word32,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: FileSize Word32,
     chunks :: [FileChunk]
   }
   deriving (Eq, Show)
 
+newtype ValidFileDescription = ValidFD FileDescription
+
+pattern ValidFileDescription :: FileDescription -> ValidFileDescription
+pattern ValidFileDescription fd = ValidFD fd
+
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
 
@@ -69,7 +78,7 @@ instance ToJSON FileDigest where
 
 data FileChunk = FileChunk
   { chunkNo :: Int,
-    chunkSize :: Word32,
+    chunkSize :: FileSize Word32,
     digest :: FileDigest,
     replicas :: [FileChunkReplica]
   }
@@ -97,11 +106,10 @@ instance ToJSON ChunkReplicaId where
   toEncoding = strToJEncoding
 
 data YAMLFileDescription = YAMLFileDescription
-  { name :: String,
-    size :: Int64,
+  { size :: String,
     digest :: FileDigest,
-    key :: C.Key,
-    iv :: C.IV,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
     chunkSize :: String,
     replicas :: [YAMLServerReplicas]
   }
@@ -127,7 +135,7 @@ data FileServerReplica = FileServerReplica
     rcvId :: ChunkReplicaId,
     rcvKey :: C.APrivateSignKey,
     digest :: Maybe FileDigest,
-    chunkSize :: Maybe Word32
+    chunkSize :: Maybe (FileSize Word32)
   }
   deriving (Show)
 
@@ -136,37 +144,49 @@ instance StrEncoding FileDescription where
   strDecode = decodeFileDescription <=< first show . Y.decodeEither'
   strP = strDecode <$?> A.takeByteString
 
+validateFileDescription :: FileDescription -> Either String ValidFileDescription
+validateFileDescription fd@FileDescription {size, chunks}
+  | chunkNos /= [1 .. length chunks] = Left "chunk numbers are not sequential"
+  | chunksSize chunks /= unFileSize size = Left "chunks total size is different than file size"
+  | otherwise = Right $ ValidFD fd
+  where
+    chunkNos = map (chunkNo :: FileChunk -> Int) chunks
+    chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
+
 encodeFileDescription :: FileDescription -> YAMLFileDescription
-encodeFileDescription FileDescription {name, size, digest, key, iv, chunkSize, chunks} =
+encodeFileDescription FileDescription {size, digest, key, nonce, chunkSize, chunks} =
   YAMLFileDescription
-    { name,
-      size,
+    { size = B.unpack $ strEncode size,
       digest,
       key,
-      iv,
-      chunkSize = B.unpack $ encodeChunkSize chunkSize,
+      nonce,
+      chunkSize = B.unpack $ strEncode chunkSize,
       replicas = encodeFileReplicas chunkSize chunks
     }
 
-encodeChunkSize :: Word32 -> ByteString
-encodeChunkSize b
-  | b' /= 0 = bshow b
-  | kb' /= 0 = bshow kb <> "kb"
-  | otherwise = bshow mb <> "mb"
-  where
-    (kb, b') = b `divMod` 1024
-    (mb, kb') = kb `divMod` 1024
+newtype FileSize a = FileSize {unFileSize :: a}
+  deriving (Eq, Show)
 
-chunkSizeP :: Parser Word32
-chunkSizeP =
-  ((mb *) <$> A.decimal <* "mb")
-    <|> ((kb *) <$> A.decimal <* "kb")
-    <|> A.decimal
-  where
-    kb = 1024
-    mb = 1024 * kb
+instance (Integral a, Show a) => StrEncoding (FileSize a) where
+  strEncode (FileSize b)
+    | b' /= 0 = bshow b
+    | kb' /= 0 = bshow kb <> "kb"
+    | otherwise = bshow mb <> "mb"
+    where
+      (kb, b') = b `divMod` 1024
+      (mb, kb') = kb `divMod` 1024
+  strP =
+    FileSize
+      <$> A.choice
+        [ (mb *) <$> A.decimal <* "mb",
+          (kb *) <$> A.decimal <* "kb",
+          A.decimal
+        ]
+    where
+      kb = 1024
+      mb = 1024 * kb
 
-encodeFileReplicas :: Word32 -> [FileChunk] -> [YAMLServerReplicas]
+encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas]
 encodeFileReplicas defChunkSize =
   map encodeServerReplicas
     . groupBy ((==) `on` server')
@@ -188,7 +208,7 @@ encodeServerReplica FileServerReplica {chunkNo, rcvId, rcvKey, digest, chunkSize
     <> ":"
     <> strEncode rcvKey
     <> maybe "" ((":" <>) . strEncode) digest
-    <> maybe "" ((":" <>) . encodeChunkSize) chunkSize
+    <> maybe "" ((":" <>) . strEncode) chunkSize
 
 serverReplicaP :: XFTPServer -> Parser FileServerReplica
 serverReplicaP server = do
@@ -196,10 +216,10 @@ serverReplicaP server = do
   rcvId <- A.char ':' *> strP
   rcvKey <- A.char ':' *> strP
   digest <- optional (A.char ':' *> strP)
-  chunkSize <- optional (A.char ':' *> chunkSizeP)
+  chunkSize <- optional (A.char ':' *> strP)
   pure FileServerReplica {chunkNo, server, rcvId, rcvKey, digest, chunkSize}
 
-unfoldChunksToReplicas :: Word32 -> [FileChunk] -> [FileServerReplica]
+unfoldChunksToReplicas :: FileSize Word32 -> [FileChunk] -> [FileServerReplica]
 unfoldChunksToReplicas defChunkSize = concatMap chunkReplicas
   where
     chunkReplicas c@FileChunk {replicas} = zipWith (replicaToServerReplica c) [1 ..] replicas
@@ -210,11 +230,12 @@ unfoldChunksToReplicas defChunkSize = concatMap chunkReplicas
        in FileServerReplica {chunkNo, server, rcvId, rcvKey, digest = digest', chunkSize = chunkSize'}
 
 decodeFileDescription :: YAMLFileDescription -> Either String FileDescription
-decodeFileDescription YAMLFileDescription {name, size, digest, key, iv, chunkSize, replicas} = do
-  chunkSize' <- parseAll chunkSizeP $ B.pack chunkSize
+decodeFileDescription YAMLFileDescription {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 FileDescription {name, size, digest, key, iv, chunkSize = chunkSize', chunks}
+  pure FileDescription {size = size', digest, key, nonce, chunkSize = chunkSize', chunks}
   where
     decodeFileParts = fmap concat . mapM decodeYAMLServerReplicas
 
@@ -225,15 +246,15 @@ decodeYAMLServerReplicas YAMLServerReplicas {server, 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 :: Word32 -> [FileServerReplica] -> Either String [FileChunk]
+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 Word32, Map Int FileDigest)
+    foldSizesDigests :: [FileServerReplica] -> Either String (Map Int (FileSize Word32), Map Int FileDigest)
     foldSizesDigests = foldl' addSizeDigest $ Right (M.empty, M.empty)
-    addSizeDigest :: Either String (Map Int Word32, Map Int FileDigest) -> FileServerReplica -> Either String (Map Int Word32, Map Int FileDigest)
+    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
@@ -242,9 +263,9 @@ foldReplicasToChunks defChunkSize fs = do
     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 Word32, Map Int FileDigest) -> [FileServerReplica] -> Either String (Map Int FileChunk)
+    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 Word32, Map Int FileDigest) -> Either String (Map Int FileChunk) -> FileServerReplica -> Either String (Map Int FileChunk)
+    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, rcvId, rcvKey} = do
       case M.lookup chunkNo cs of
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 9b68c4172..2cd084a68 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -691,13 +691,6 @@ processSubResult c rq r = do
     _ -> addSubscription c rq
   pure r
 
-temporaryClientError :: ProtocolClientError -> Bool
-temporaryClientError = \case
-  PCENetworkError -> True
-  PCEResponseTimeout -> True
-  PCEIOError _ -> True
-  _ -> False
-
 temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
   BROKER _ NETWORK -> True
diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index 1af672873..a84c78277 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -63,6 +63,7 @@ module Simplex.Messaging.Client
     transportClientConfig,
     chooseTransportHost,
     proxyUsername,
+    temporaryClientError,
     ServerTransmission,
     ClientCommand,
   )
@@ -418,6 +419,13 @@ data ProtocolClientError
     PCEIOError IOException
   deriving (Eq, Show, Exception)
 
+temporaryClientError :: ProtocolClientError -> 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
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 05b9b14ed..31c352aa9 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -117,12 +117,14 @@ module Simplex.Messaging.Crypto
     sbEncrypt,
     sbDecrypt,
     sbKey,
+    unsafeSbKey,
     randomSbKey,
+    cbAuthTagSize,
 
     -- * pseudo-random bytes
     pseudoRandomBytes,
 
-    -- * SHA256 hash
+    -- * hash
     sha256Hash,
 
     -- * Message padding / un-padding
@@ -149,7 +151,7 @@ import Crypto.Cipher.AES (AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
-import Crypto.Hash (Digest, SHA256 (..), hash)
+import Crypto.Hash (Digest, SHA256, hash)
 import qualified Crypto.MAC.Poly1305 as Poly1305
 import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
@@ -973,6 +975,9 @@ sbDecrypt_ secret (CbNonce nonce) packet
     (rs, msg) = xSalsa20 secret nonce c
     tag = Poly1305.auth rs c
 
+cbAuthTagSize :: Int
+cbAuthTagSize = 16
+
 newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
   deriving (Eq, Show)
 
@@ -989,6 +994,9 @@ instance ToJSON CbNonce where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance FromJSON CbNonce where
+  parseJSON = strParseJSON "CbNonce"
+
 cbNonce :: ByteString -> CbNonce
 cbNonce s
   | len == 24 = CryptoBoxNonce s
@@ -1020,19 +1028,22 @@ 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"
+
+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
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
index 9cfb3876b..b8fa62da9 100644
--- a/tests/FileDescriptionTests.hs
+++ b/tests/FileDescriptionTests.hs
@@ -15,26 +15,42 @@ 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"
 
+mb :: Num a => a
+mb = 1024 * 1024
+
+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
 fileDesc =
   FileDescription
-    { name = "file.ext",
-      size = 33200000,
+    { size = FileSize $ 26 * mb,
       digest = FileDigest "abc",
-      key = C.Key "def",
-      iv = C.IV "ghi",
-      chunkSize = 8 * 1024 * 1024,
+      key = testSbKey,
+      nonce = testCbNonce,
+      chunkSize = defaultChunkSize,
       chunks =
         [ FileChunk
             { chunkNo = 1,
               digest = chunkDigest,
-              chunkSize = 8 * 1024 * 1024,
+              chunkSize = defaultChunkSize,
               replicas =
                 [ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
                   FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
@@ -43,7 +59,7 @@ fileDesc =
           FileChunk
             { chunkNo = 2,
               digest = chunkDigest,
-              chunkSize = 8 * 1024 * 1024,
+              chunkSize = defaultChunkSize,
               replicas =
                 [ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
                   FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
@@ -52,7 +68,7 @@ fileDesc =
           FileChunk
             { chunkNo = 3,
               digest = chunkDigest,
-              chunkSize = 8 * 1024 * 1024,
+              chunkSize = defaultChunkSize,
               replicas =
                 [ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
                   FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
@@ -61,7 +77,7 @@ fileDesc =
           FileChunk
             { chunkNo = 4,
               digest = chunkDigest,
-              chunkSize = 2 * 1024 * 1024,
+              chunkSize = FileSize $ 2 * mb,
               replicas =
                 [ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
                   FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
@@ -70,6 +86,7 @@ fileDesc =
         ]
     }
   where
+    defaultChunkSize = FileSize $ 8 * mb
     rcvId = ChunkReplicaId "abc"
     rcvKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
     chunkDigest = FileDigest "ghi"
@@ -77,12 +94,11 @@ fileDesc =
 yamlFileDesc :: YAMLFileDescription
 yamlFileDesc =
   YAMLFileDescription
-    { name = "file.ext",
-      size = 33200000,
+    { size = "26mb",
       chunkSize = "8mb",
       digest = FileDigest "abc",
-      key = C.Key "def",
-      iv = C.IV "ghi",
+      key = testSbKey,
+      nonce = testCbNonce,
       replicas =
         [ YAMLServerReplicas
             { server = "xftp://abc=@example1.com",
@@ -115,14 +131,6 @@ yamlFileDesc =
         ]
     }
 
-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
-
 testParseYAMLFileDescription :: IO ()
 testParseYAMLFileDescription = do
   yfd <- Y.decodeFileThrow fileDescPath
diff --git a/tests/fixtures/file_description.yaml b/tests/fixtures/file_description.yaml
index 42f521d1f..a96e9a4f3 100644
--- a/tests/fixtures/file_description.yaml
+++ b/tests/fixtures/file_description.yaml
@@ -1,8 +1,7 @@
 chunkSize: 8mb
 digest: YWJj
-iv: Z2hp
-key: ZGVm
-name: file.ext
+key: 00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=
+nonce: dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu
 replicas:
 - chunks:
   - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
@@ -20,4 +19,4 @@ replicas:
   - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
   - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
   server: xftp://abc=@example4.com
-size: 33200000
+size: 26mb

From cf7346d48b5e177fe258dbc34c6f5bad8f01b54f Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 16 Feb 2023 21:01:41 +0400
Subject: [PATCH 10/71] xftp: cli - verify file digest (#640)

---
 src/Simplex/FileTransfer/Client/Main.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 4a7504211..5cac39829 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -289,7 +289,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, retryCount, tempPat
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} = do
   fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile fileDescription
-  ValidFileDescription FileDescription {size, key, nonce, chunks} <- liftEither . first CLIError $ validateFileDescription fd
+  ValidFileDescription FileDescription {size, digest, key, nonce, chunks} <- liftEither . first CLIError $ validateFileDescription fd
   encPath <- getEncPath tempPath "xftp"
   -- withFile encPath WriteMode $ \h -> do
   --   liftIO $ LB.hPut h $ LB.replicate (unFileSize size) '#'
@@ -300,7 +300,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
   -- chunks have to be ordered because of AppendMode
   forM_ (zip chunkSpecs chunks) $ \(chunkSpec, chunk) -> do
     downloadFileChunk a writeLock chunk chunkSpec
-  -- verify file digest
+  encDigest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
+  when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
   decryptFile encPath key nonce
   whenM (doesFileExist encPath) $ removeFile encPath
   where

From a3d9ee213dbb1568ab3a51cc5f1232fb4746d33b Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 16 Feb 2023 21:06:23 +0400
Subject: [PATCH 11/71] xftp: cli - option to pass servers, choose servers
 randomly (#641)

---
 src/Simplex/FileTransfer/Client/Main.hs | 38 ++++++++++++++++++++-----
 1 file changed, 31 insertions(+), 7 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 5cac39829..3bd5991fe 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -7,6 +7,7 @@
 
 module Simplex.FileTransfer.Client.Main (xftpClientCLI) where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad
 import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
@@ -17,6 +18,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.List (foldl', sortOn)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
 import qualified Data.Map as M
@@ -32,12 +34,14 @@ 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 (SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer)
 import Simplex.Messaging.Server.CLI (getCliCommand')
 import Simplex.Messaging.Util (ifM, whenM)
 import System.Exit (exitFailure)
 import System.FilePath (splitExtensions, splitFileName, (</>))
 import System.IO.Temp (getCanonicalTemporaryDirectory)
+import System.Random (StdGen, newStdGen, randomR)
 import UnliftIO
 import UnliftIO.Directory
 
@@ -71,6 +75,7 @@ data SendOptions = SendOptions
   { filePath :: FilePath,
     outputDir :: Maybe FilePath,
     numRecipients :: Int,
+    xftpServers :: [XFTPServer],
     retryCount :: Int,
     tempPath :: Maybe FilePath
   }
@@ -93,8 +98,8 @@ data RandomFileOptions = RandomFileOptions
 defaultRetryCount :: Int
 defaultRetryCount = 3
 
-xftpServer :: XFTPServer
-xftpServer = "xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"
+defaultXFTPServers :: NonEmpty XFTPServer
+defaultXFTPServers = L.fromList ["xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"]
 
 cliCommandP :: Parser CliCommand
 cliCommandP =
@@ -110,6 +115,7 @@ cliCommandP =
         <$> 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
         <*> retries
         <*> temp
     receiveP :: Parser ReceiveOptions
@@ -127,6 +133,17 @@ cliCommandP =
     strDec = eitherReader $ strDecode . B.pack
     retries = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
     temp = optional (strOption $ long "temp" <> metavar "TEMP" <> help "Directory for temporary encrypted file (default: system temp directory)")
+    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,
@@ -183,7 +200,7 @@ instance Encoding FileHeader where
     pure FileHeader {fileName, fileExtra}
 
 cliSendFile :: SendOptions -> ExceptT CLIError IO ()
-cliSendFile SendOptions {filePath, outputDir, numRecipients, retryCount, tempPath} = do
+cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
   let (_, fileName) = splitFileName filePath
   (encPath, fd, chunkSpecs) <- encryptFile fileName
   sentChunks <- uploadFile chunkSpecs
@@ -218,18 +235,20 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, retryCount, tempPat
     uploadFile :: [XFTPChunkSpec] -> ExceptT CLIError IO [SentFileChunk]
     uploadFile chunks = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      gen <- newTVarIO =<< liftIO newStdGen
+      let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers)
       -- TODO shuffle chunks
-      sentChunks <- pooledForConcurrentlyN 32 (zip [1 ..] chunks) $ uploadFileChunk a
+      sentChunks <- pooledForConcurrentlyN 32 (zip [1 ..] chunks) $ uploadFileChunk a gen xftpSrvs
       -- TODO unshuffle chunks
       pure $ map snd sentChunks
       where
         retries = withRetry retryCount
-        uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
-        uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
+        uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
+        uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
           (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
           rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
           chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
-          -- TODO choose server randomly
+          xftpServer <- liftIO $ getXFTPServer gen srvs
           c <- retries $ withExceptT (CLIError . show) $ getXFTPServerClient a xftpServer
           (sndId, rIds) <- retries $ withExceptT (CLIError . show) $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
           retries $ withExceptT (CLIError . show) $ uploadXFTPChunk c spKey sndId chunkSpec
@@ -242,6 +261,11 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, retryCount, tempPat
             hSeek h AbsoluteSeek $ fromIntegral chunkOffset
             digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
             pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
+        getXFTPServer :: TVar StdGen -> NonEmpty XFTPServer -> IO XFTPServer
+        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]

From acdf4f41c51d428c0d835c243fb0e9054a225623 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 17 Feb 2023 11:38:43 +0000
Subject: [PATCH 12/71] XFTP: CLI tests, output command results, info command
 (#642)

* XFTP: CLI tests, output command results

* info command, test

* fix test
---
 simplexmq.cabal                         |  1 +
 src/Simplex/FileTransfer/Client/Main.hs | 75 +++++++++++++++++++------
 src/Simplex/FileTransfer/Description.hs | 20 +++++--
 tests/Test.hs                           |  2 +
 tests/XFTPCLI.hs                        | 53 +++++++++++++++++
 tests/XFTPClient.hs                     | 40 ++++++++++++-
 tests/XFTPServerTests.hs                | 10 ++--
 7 files changed, 171 insertions(+), 30 deletions(-)
 create mode 100644 tests/XFTPCLI.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 9ff4070e9..96c8a5e7f 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -516,6 +516,7 @@ test-suite simplexmq-test
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPCLI
       XFTPClient
       XFTPServerTests
       Paths_simplexmq
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 3bd5991fe..586c8290c 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -28,6 +28,7 @@ import Options.Applicative
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Client.Agent
 import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Description (FileSize (unFileSize))
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.Messaging.Agent.Lock
 import qualified Simplex.Messaging.Crypto as C
@@ -70,6 +71,7 @@ data CliCommand
   = SendFile SendOptions
   | ReceiveFile ReceiveOptions
   | RandomFile RandomFileOptions
+  | FileDescrInfo InfoOptions
 
 data SendOptions = SendOptions
   { filePath :: FilePath,
@@ -89,6 +91,11 @@ data ReceiveOptions = ReceiveOptions
   }
   deriving (Show)
 
+newtype InfoOptions = InfoOptions
+  { fileDescription :: FilePath
+  }
+  deriving (Show)
+
 data RandomFileOptions = RandomFileOptions
   { filePath :: FilePath,
     fileSize :: FileSize Int
@@ -106,6 +113,7 @@ cliCommandP =
   hsubparser
     ( command "send" (info (SendFile <$> sendP) (progDesc "Send file"))
         <> command "recv" (info (ReceiveFile <$> receiveP) (progDesc "Receive file"))
+        <> command "info" (info (FileDescrInfo <$> infoP) (progDesc "Show file description"))
         <> command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size"))
     )
   where
@@ -121,18 +129,21 @@ cliCommandP =
     receiveP :: Parser ReceiveOptions
     receiveP =
       ReceiveOptions
-        <$> argument str (metavar "FILE" <> help "File description file")
+        <$> fileDescrArg
         <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
         <*> retries
         <*> temp
+    infoP :: Parser InfoOptions
+    infoP = InfoOptions <$> fileDescrArg
     randomP :: Parser RandomFileOptions
     randomP =
       RandomFileOptions
         <$> argument str (metavar "FILE" <> help "Path to save file")
         <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb)")
     strDec = eitherReader $ strDecode . B.pack
+    fileDescrArg = argument str (metavar "FILE" <> help "File description file")
     retries = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
-    temp = optional (strOption $ long "temp" <> metavar "TEMP" <> help "Directory for temporary encrypted file (default: system temp directory)")
+    temp = optional (strOption $ long "tmp" <> metavar "TMP" <> help "Directory for temporary encrypted file (default: system temp directory)")
     xftpServers =
       option
         parseXFTPServers
@@ -176,6 +187,7 @@ xftpClientCLI =
   getCliCommand' cliCommandP clientVersion >>= \case
     SendFile opts -> runE $ cliSendFile opts
     ReceiveFile opts -> runE $ cliReceiveFile opts
+    FileDescrInfo opts -> runE $ cliFileDescrInfo opts
     RandomFile opts -> cliRandomFile opts
   where
     clientVersion = "SimpleX XFTP client v" <> xftpClientVersion
@@ -206,7 +218,10 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
   sentChunks <- uploadFile chunkSpecs
   whenM (doesFileExist encPath) $ removeFile encPath
   -- TODO if only small chunks, use different default size
-  liftIO $ writeFileDescriptions fileName $ createFileDescriptions fd sentChunks
+  liftIO $ do
+    fds <- writeFileDescriptions fileName $ createFileDescriptions fd sentChunks
+    putStrLn "File uploaded!\nPass file descriptions to the recipient(s):"
+    forM_ fds putStrLn
   where
     encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription, [XFTPChunkSpec])
     encryptFile fileName = do
@@ -242,16 +257,17 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       -- TODO unshuffle chunks
       pure $ map snd sentChunks
       where
-        retries = withRetry retryCount
+        retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
+        retries = withRetry retryCount . withExceptT (CLIError . show)
         uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
           (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
           rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
           chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
           xftpServer <- liftIO $ getXFTPServer gen srvs
-          c <- retries $ withExceptT (CLIError . show) $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- retries $ withExceptT (CLIError . show) $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
-          retries $ withExceptT (CLIError . show) $ uploadXFTPChunk c spKey sndId chunkSpec
+          c <- retries $ getXFTPServerClient a xftpServer
+          (sndId, rIds) <- retries $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
+          retries $ uploadXFTPChunk c spKey sndId chunkSpec
           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})
@@ -302,18 +318,18 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
               Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas}
               _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
             replica = FileChunkReplica {server, rcvId, rcvKey}
-    writeFileDescriptions :: String -> [FileDescription] -> IO ()
+    writeFileDescriptions :: String -> [FileDescription] -> IO [FilePath]
     writeFileDescriptions fileName fds = do
       outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
       createDirectoryIfMissing True outDir
-      forM_ (zip [1 ..] fds) $ \(i, fd) -> do
+      forM (zip [1 ..] fds) $ \(i :: Int, fd) -> do
         let fdPath = outDir </> ("rcv" <> show i <> ".xftp")
         B.writeFile fdPath $ strEncode fd
+        pure fdPath
 
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} = do
-  fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile fileDescription
-  ValidFileDescription FileDescription {size, digest, key, nonce, chunks} <- liftEither . first CLIError $ validateFileDescription fd
+  ValidFileDescription FileDescription {size, digest, key, nonce, chunks} <- getFileDescription fileDescription
   encPath <- getEncPath tempPath "xftp"
   -- withFile encPath WriteMode $ \h -> do
   --   liftIO $ LB.hPut h $ LB.replicate (unFileSize size) '#'
@@ -326,21 +342,24 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
     downloadFileChunk a writeLock chunk chunkSpec
   encDigest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
   when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
-  decryptFile encPath key nonce
+  path <- decryptFile encPath key nonce
   whenM (doesFileExist encPath) $ removeFile encPath
+  liftIO $ putStrLn $ "File received: " <> path
   where
+    retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
+    retries = withRetry retryCount . withExceptT (CLIError . show)
     downloadFileChunk :: XFTPClientAgent -> Lock -> FileChunk -> XFTPChunkSpec -> ExceptT CLIError IO ()
     downloadFileChunk a writeLock FileChunk {replicas = replica : _} chunkSpec = do
       let FileChunkReplica {server, rcvId, rcvKey} = replica
-      c <- withRetry retryCount $ withExceptT (CLIError . show) $ getXFTPServerClient a server
+      c <- retries $ getXFTPServerClient a server
       (rKey, rpKey) <- liftIO C.generateKeyPair'
-      (sKey, body) <- withRetry retryCount $ withExceptT (CLIError . show) $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey
+      (sKey, body) <- retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey
       -- download and decrypt (DH) chunk from server using XFTPClient
       -- verify chunk digest - in the client
       -- save to correct location in file - also in the client
-      withRetry retryCount $ withExceptT (CLIError . show) $ withLock writeLock "save" $ receiveXFTPChunk body chunkSpec
+      retries $ withLock writeLock "save" $ receiveXFTPChunk body chunkSpec
     downloadFileChunk _ _ _ _ = pure ()
-    decryptFile :: FilePath -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO ()
+    decryptFile :: FilePath -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
     decryptFile encPath key nonce = do
       f <- liftIO $ LB.readFile encPath
       f' <- liftEither $ first (CLIError . show) $ LC.sbDecrypt key nonce f
@@ -353,6 +372,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
         A.Done rest FileHeader {fileName} -> do
           path <- getFilePath fileName
           liftIO $ LB.writeFile path $ LB.fromStrict rest <> f''
+          pure path
     getFilePath :: String -> ExceptT CLIError IO FilePath
     getFilePath name =
       case filePath of
@@ -361,6 +381,26 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
             ifM (doesFileExist path) (throwError $ CLIError "File already exists") (pure path)
         _ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
 
+cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
+cliFileDescrInfo InfoOptions {fileDescription} = do
+  ValidFileDescription FileDescription {size, chunkSize, chunks} <- getFileDescription fileDescription
+  let replicas = groupReplicasByServer chunkSize chunks
+  liftIO $ do
+    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)
+
+strEnc :: StrEncoding a => a -> String
+strEnc = B.unpack . strEncode
+
+getFileDescription :: FilePath -> ExceptT CLIError IO ValidFileDescription
+getFileDescription path = do
+  fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
+  liftEither . first CLIError $ validateFileDescription fd
+
 prepareChunkSizes :: Int64 -> [Word32]
 prepareChunkSizes 0 = []
 prepareChunkSizes size
@@ -398,8 +438,9 @@ withRetry 1 a = a
 withRetry n a = a `catchError` \_ -> withRetry (n - 1) a
 
 cliRandomFile :: RandomFileOptions -> IO ()
-cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} =
+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
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 8bdc4f300..c4cdc5d6e 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -14,11 +14,14 @@ module Simplex.FileTransfer.Description
     FileDigest (..),
     FileChunk (..),
     FileChunkReplica (..),
+    FileServerReplica (..),
     FileSize (..),
     ChunkReplicaId (..),
     YAMLFileDescription (..), -- for tests
     YAMLServerReplicas (..), -- for tests
     validateFileDescription,
+    groupReplicasByServer,
+    replicaServer,
   )
 where
 
@@ -186,20 +189,25 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
       kb = 1024
       mb = 1024 * kb
 
+groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
+groupReplicasByServer defChunkSize =
+  groupBy ((==) `on` replicaServer)
+    . sortOn replicaServer
+    . unfoldChunksToReplicas defChunkSize
+
 encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas]
 encodeFileReplicas defChunkSize =
-  map encodeServerReplicas
-    . groupBy ((==) `on` server')
-    . sortOn server'
-    . unfoldChunksToReplicas defChunkSize
+  map encodeServerReplicas . groupReplicasByServer defChunkSize
   where
-    server' = server :: FileServerReplica -> XFTPServer
     encodeServerReplicas fs =
       YAMLServerReplicas
-        { server = server' $ head fs, -- groupBy guarantees that fs is not empty
+        { 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, rcvId, rcvKey, digest, chunkSize} =
   bshow chunkNo
diff --git a/tests/Test.hs b/tests/Test.hs
index 45d3afbb0..2643674f6 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -16,6 +16,7 @@ import Simplex.Messaging.Transport.WebSockets (WS)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
+import XFTPCLI
 import XFTPServerTests (xftpServerTests)
 
 logCfg :: LogConfig
@@ -44,4 +45,5 @@ main = do
         describe "XFTP" $ do
           describe "XFTP server" xftpServerTests
           describe "XFTP file description" fileDescriptionTests
+          describe "XFTP CLI" xftpCLITests
         describe "Server CLIs" cliTests
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
new file mode 100644
index 000000000..dd7897d67
--- /dev/null
+++ b/tests/XFTPCLI.hs
@@ -0,0 +1,53 @@
+module XFTPCLI where
+
+import Control.Exception (bracket_)
+import qualified Data.ByteString as LB
+import Simplex.FileTransfer.Client.Main (xftpClientCLI)
+import System.Directory (createDirectoryIfMissing, getFileSize, removeDirectoryRecursive)
+import System.Environment (withArgs)
+import System.FilePath ((</>))
+import System.IO.Silently (capture_)
+import Test.Hspec
+import XFTPClient (testXFTPServerStr, withXFTPServer, xftpServerFiles, xftpServerFiles2)
+
+xftpCLITests :: Spec
+xftpCLITests = around_ testBracket . describe "XFTP CLI" $ do
+  it "should send and receive file" testXFTPCLISendReceive
+
+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"
+
+mb :: Num a => a
+mb = 1024 * 1024
+
+testXFTPCLISendReceive :: IO ()
+testXFTPCLISendReceive = withXFTPServer $ do
+  let filePath = senderFiles </> "testfile"
+  xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` 19 * mb
+  let fd1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fd2 = filePath <> ".xftp" </> "rcv2.xftp"
+  xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+    `shouldReturn` ["File uploaded!", "Pass file descriptions to the recipient(s):", fd1, fd2]
+  testReceiveFile fd1 "testfile" file
+  testReceiveFile fd2 "testfile_1" file
+  where
+    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
+    testReceiveFile fd fileName file = do
+      xftp ["info", fd]
+        `shouldReturn` ["File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
+      xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+        `shouldReturn` ["File received: " <> recipientFiles </> fileName]
+      LB.readFile (recipientFiles </> fileName) `shouldReturn` file
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index c41a20e1c..6f7242126 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -1,10 +1,12 @@
 {-# 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
@@ -16,9 +18,25 @@ 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)
+
 withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
 withXFTPServerCfg cfg =
   serverBracket
@@ -28,11 +46,29 @@ withXFTPServerCfg cfg =
 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 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000"
+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"
 
 testXFTPServerConfig :: XFTPServerConfig
 testXFTPServerConfig =
@@ -40,7 +76,7 @@ testXFTPServerConfig =
     { xftpPort = xftpTestPort,
       fileIdSize = 16,
       storeLogFile = Nothing,
-      filesPath = "tests/xftp-files",
+      filesPath = xftpServerFiles,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 9ba61c51a..7ea5719b5 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -16,14 +16,14 @@ import Simplex.FileTransfer.Protocol (FileInfo (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (SenderId)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
-import System.IO (IOMode (..), withFile)
+import System.FilePath ((</>))
 import Test.Hspec
 import XFTPClient
 
 xftpServerTests :: Spec
 xftpServerTests =
-  before_ (createDirectoryIfMissing False "tests/xftp-files")
-    . after_ (removeDirectoryRecursive "tests/xftp-files")
+  before_ (createDirectoryIfMissing False xftpServerFiles)
+    . after_ (removeDirectoryRecursive xftpServerFiles)
     $ do
       describe "XFTP file chunk delivery" testFileChunkDelivery
 
@@ -33,11 +33,11 @@ chSize = 256 * 1024
 createTestChunk :: FilePath -> IO ByteString
 createTestChunk fp = do
   bytes <- getRandomBytes chSize
-  withFile fp WriteMode $ \h -> B.hPut h bytes
+  B.writeFile fp bytes
   pure bytes
 
 readChunk :: SenderId -> IO ByteString
-readChunk sId = B.readFile ("tests/xftp-files/" <> B.unpack (B64.encode sId))
+readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))
 
 testFileChunkDelivery :: Spec
 testFileChunkDelivery =

From bd0cc250835751a9a232e552a733b894bd5bc530 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 17 Feb 2023 22:27:36 +0000
Subject: [PATCH 13/71] XFTP error type

---
 src/Simplex/FileTransfer/Client.hs       | 21 +++---
 src/Simplex/FileTransfer/Client/Agent.hs |  2 +-
 src/Simplex/FileTransfer/Client/Main.hs  |  1 -
 src/Simplex/FileTransfer/Protocol.hs     | 85 +++++++++++++++++++++---
 src/Simplex/FileTransfer/Server.hs       |  6 +-
 src/Simplex/FileTransfer/Server/Store.hs | 18 ++---
 6 files changed, 100 insertions(+), 33 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index e0528e0ce..bf64366e2 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -31,8 +31,7 @@ import Simplex.Messaging.Client
   )
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
-  ( ErrorType (..),
-    ProtocolServer (ProtocolServer),
+  ( ProtocolServer (ProtocolServer),
     RcvPublicDhKey,
     RecipientId,
     SenderId,
@@ -67,10 +66,12 @@ data XFTPChunkSpec = XFTPChunkSpec
   }
   deriving (Show)
 
+type XFTPClientError = ProtocolClientError XFTPErrorType
+
 defaultXFTPClientConfig :: XFTPClientConfig
 defaultXFTPClientConfig = XFTPClientConfig {networkConfig = defaultNetworkConfig}
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either ProtocolClientError XFTPClient)
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either XFTPClientError XFTPClient)
 getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfig} disconnected = runExceptT $ do
   let tcConfig = transportClientConfig networkConfig
       http2Config = xftpHTTP2Config tcConfig config
@@ -89,13 +90,13 @@ xftpHTTP2Config transportConfig XFTPClientConfig {networkConfig = NetworkConfig
       transportConfig
     }
 
-xftpClientError :: HTTP2ClientError -> ProtocolClientError
+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 ProtocolClientError IO (FileResponse, HTTP2Body)
+sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
 sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
   t <-
     liftEither . first PCETransportError $
@@ -123,21 +124,21 @@ createXFTPChunk ::
   C.APrivateSignKey ->
   FileInfo ->
   NonEmpty C.APublicVerifyKey ->
-  ExceptT ProtocolClientError IO (SenderId, NonEmpty RecipientId)
+  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
 createXFTPChunk c spKey file rsps =
   sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
     -- TODO check that body is empty
     (FRSndIds sId rIds, _body) -> pure (sId, rIds)
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT ProtocolClientError IO ()
+uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
 uploadXFTPChunk c spKey fId chunkSpec =
   sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= \case
     -- TODO check that body is empty
     (FROk, _body) -> pure ()
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> ExceptT ProtocolClientError IO (RcvPublicDhKey, XFTPChunkBody)
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> ExceptT XFTPClientError IO (RcvPublicDhKey, XFTPChunkBody)
 downloadXFTPChunk c rpKey fId rKey =
   sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case
     (FRFile sKey, http2Body@HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
@@ -145,10 +146,10 @@ downloadXFTPChunk c rpKey fId rKey =
       Just chunkPart -> do
         let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body}
         pure (sKey, chunk)
-      _ -> throwError $ PCEResponseError NO_MSG
+      _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT ProtocolClientError IO ()
+receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
 receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset} = liftIO $ do
   withFile filePath AppendMode $ \h -> do
     -- hSeek h AbsoluteSeek $ fromIntegral chunkOffset
diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs
index 63cc77ed0..f52f229fc 100644
--- a/src/Simplex/FileTransfer/Client/Agent.hs
+++ b/src/Simplex/FileTransfer/Client/Agent.hs
@@ -47,7 +47,7 @@ defaultXFTPClientAgentConfig =
           }
     }
 
-data XFTPClientAgentError = XFTPClientAgentError XFTPServer ProtocolClientError
+data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
   deriving (Show, Exception)
 
 newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 586c8290c..5d85d16fe 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -28,7 +28,6 @@ import Options.Applicative
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Client.Agent
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Description (FileSize (unFileSize))
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.Messaging.Agent.Lock
 import qualified Simplex.Messaging.Crypto as C
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 36369d09f..3353e0e26 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -11,6 +13,7 @@
 
 module Simplex.FileTransfer.Protocol where
 
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -19,15 +22,16 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
+import GHC.Generics (Generic)
 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.Protocol
   ( CommandError (..),
-    ErrorType (..),
     Protocol (..),
     ProtocolEncoding (..),
+    ProtocolErrorType (..),
     ProtocolMsgTag (..),
     ProtocolType (..),
     RcvPublicDhKey,
@@ -119,7 +123,7 @@ instance ProtocolMsgTag FileCmdTag where
 instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
   decodeTag s = decodeTag s >>= (\(FCT _ t) -> checkParty' t)
 
-instance Protocol FileResponse where
+instance Protocol XFTPErrorType FileResponse where
   type ProtoCommand FileResponse = FileCmd
   type ProtoType FileResponse = 'PXFTP
   protocolClientHandshake = ntfClientHandshake
@@ -152,7 +156,7 @@ data FileInfo = FileInfo
 
 type XFTPFileId = ByteString
 
-instance FilePartyI p => ProtocolEncoding (FileCommand p) where
+instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
   encodeProtocol _v = \case
     FNEW file rKeys -> e (FNEW_, ' ', file, rKeys)
@@ -168,6 +172,9 @@ instance FilePartyI p => ProtocolEncoding (FileCommand p) where
 
   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 {}
@@ -182,7 +189,7 @@ instance FilePartyI p => ProtocolEncoding (FileCommand p) where
       | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
-instance ProtocolEncoding FileCmd where
+instance ProtocolEncoding XFTPErrorType FileCmd where
   type Tag FileCmd = FileCmdTag
   encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
 
@@ -199,6 +206,9 @@ instance ProtocolEncoding FileCmd where
         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
@@ -243,11 +253,11 @@ data FileResponse
   | FRRcvIds (NonEmpty RecipientId)
   | FRFile RcvPublicDhKey
   | FROk
-  | FRErr ErrorType
+  | FRErr XFTPErrorType
   | FRPong
   deriving (Show)
 
-instance ProtocolEncoding FileResponse where
+instance ProtocolEncoding XFTPErrorType FileResponse where
   type Tag FileResponse = FileResponseTag
   encodeProtocol _v = \case
     FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
@@ -268,6 +278,13 @@ instance ProtocolEncoding FileResponse where
     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
@@ -283,6 +300,56 @@ instance ProtocolEncoding FileResponse where
         | 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
+  | -- | incorrent file digest
+    DIGEST
+  | -- | no file body
+    NO_FILE
+  | -- | unexpected file body
+    HAS_FILE
+  | -- | 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 Encoding XFTPErrorType where
+  smpEncode = \case
+    BLOCK -> "BLOCK"
+    SESSION -> "SESSION"
+    CMD err -> "CMD " <> smpEncode err
+    AUTH -> "AUTH"
+    SIZE -> "SIZE"
+    DIGEST -> "DIGEST"
+    NO_FILE -> "NO_FILE"
+    HAS_FILE -> "HAS_FILE"
+    INTERNAL -> "INTERNAL"
+    DUPLICATE_ -> "DUPLICATE_"
+
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "BLOCK" -> pure BLOCK
+      "SESSION" -> pure SESSION
+      "CMD" -> CMD <$> _smpP
+      "AUTH" -> pure AUTH
+      "SIZE" -> pure SIZE
+      "DIGEST" -> pure DIGEST
+      "NO_FILE" -> pure NO_FILE
+      "HAS_FILE" -> pure HAS_FILE
+      "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
@@ -293,7 +360,7 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Just c
   _ -> Nothing
 
-xftpEncodeTransmission :: ProtocolEncoding c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString
+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
@@ -307,9 +374,9 @@ xftpEncodeBatch1 (sig, t) =
   let t' = tEncodeBatch 1 . smpEncode . Large $ tEncode (sig, t)
    in first (const TELargeMsg) $ C.pad t' xftpBlockSize
 
-xftpDecodeTransmission :: ProtocolEncoding c => SessionId -> ByteString -> Either ErrorType (SignedTransmission c)
+xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
 xftpDecodeTransmission sessionId t = do
-  t' <- first (const LARGE_MSG) $ C.unPad t
+  t' <- first (const BLOCK) $ C.unPad t
   case tParse True t' of
     t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t''
     _ -> Left BLOCK
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 26ba37ae5..a5f2b54bc 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -37,7 +37,7 @@ import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Transport (receiveFile, sendFile)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId, ErrorType (..), RcvPublicDhKey)
+import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
@@ -207,7 +207,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     noFile resp = pure (resp, Nothing)
     receiveServerFile :: FileRec -> M FileResponse
     receiveServerFile FileRec {senderId, fileInfo, filePath} = case bodyPart of
-      Nothing -> pure $ FRErr QUOTA -- TODO file specific errors?
+      Nothing -> pure $ FRErr SIZE -- TODO file specific errors?
       Just getBody -> do
         -- TODO validate body size before downloading, once it's populated
         path <- asks $ filesPath . config
@@ -216,7 +216,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         size' <- liftIO . withFile fPath WriteMode $ \h -> receiveFile h getBody 0
         if size' == fromIntegral size -- TODO check digest
           then atomically $ writeTVar filePath (Just fPath) $> FROk
-          else whenM (doesFileExist fPath) (removeFile fPath) $> FRErr QUOTA
+          else whenM (doesFileExist fPath) (removeFile fPath) $> FRErr SIZE
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
       readTVarIO filePath >>= \case
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index bbacd8335..9ea6f0496 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -20,9 +20,9 @@ import Control.Concurrent.STM
 import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
-import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol hiding (SParty, SRecipient, SSender)
+import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM)
@@ -46,7 +46,7 @@ newFileStore = do
   recipients <- TM.empty
   pure FileStore {files, recipients}
 
-addFile :: FileStore -> SenderId -> FileInfo -> STM (Either ErrorType ())
+addFile :: FileStore -> SenderId -> FileInfo -> STM (Either XFTPErrorType ())
 addFile FileStore {files} sId fileInfo =
   ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
     f <- newFileRec sId fileInfo
@@ -59,12 +59,12 @@ newFileRec senderId fileInfo = do
   filePath <- newTVar Nothing
   pure FileRec {senderId, fileInfo, filePath, recipientIds}
 
-setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either ErrorType ())
+setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ())
 setFilePath st sId fPath =
   withFile st sId $ \FileRec {filePath} ->
     writeTVar filePath (Just fPath) $> Right ()
 
-addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either ErrorType ())
+addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either XFTPErrorType ())
 addRecipient st@FileStore {recipients} senderId (rId, rKey) =
   withFile st senderId $ \FileRec {recipientIds} -> do
     rIds <- readTVar recipientIds
@@ -76,7 +76,7 @@ addRecipient st@FileStore {recipients} senderId (rId, rKey) =
         TM.insert rId (senderId, rKey) recipients
         pure $ Right ()
 
-deleteFile :: FileStore -> SenderId -> STM (Either ErrorType ())
+deleteFile :: FileStore -> SenderId -> STM (Either XFTPErrorType ())
 deleteFile FileStore {files, recipients} senderId = do
   TM.lookupDelete senderId files >>= \case
     Just FileRec {recipientIds} -> do
@@ -84,7 +84,7 @@ deleteFile FileStore {files, recipients} senderId = do
       pure $ Right ()
     _ -> pure $ Left AUTH
 
-getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either ErrorType (FileRec, C.APublicVerifyKey))
+getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey))
 getFile st party fId = case party of
   SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
   SRecipient ->
@@ -92,7 +92,7 @@ getFile st party fId = case party of
       Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey)
       _ -> pure $ Left AUTH
 
-ackFile :: FileStore -> RecipientId -> STM (Either ErrorType ())
+ackFile :: FileStore -> RecipientId -> STM (Either XFTPErrorType ())
 ackFile st@FileStore {recipients} recipientId = do
   TM.lookupDelete recipientId recipients >>= \case
     Just (sId, _) ->
@@ -101,7 +101,7 @@ ackFile st@FileStore {recipients} recipientId = do
         pure $ Right ()
     _ -> pure $ Left AUTH
 
-withFile :: FileStore -> SenderId -> (FileRec -> STM (Either ErrorType a)) -> STM (Either ErrorType a)
+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

From 628169adb46274808c6c4f1b83ac127e1ad8efaf Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Feb 2023 19:47:17 +0000
Subject: [PATCH 14/71] xftp: only receive correct number of bytes

---
 src/Simplex/FileTransfer/Client.hs    | 15 ++++++++------
 src/Simplex/FileTransfer/Server.hs    | 11 +++++-----
 src/Simplex/FileTransfer/Transport.hs | 29 ++++++++++++++++-----------
 3 files changed, 32 insertions(+), 23 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index bf64366e2..b8af2cf06 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -16,6 +16,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.Word (Word32)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
 import Simplex.FileTransfer.Protocol
@@ -62,7 +63,7 @@ data XFTPChunkBody = XFTPChunkBody
 data XFTPChunkSpec = XFTPChunkSpec
   { filePath :: FilePath,
     chunkOffset :: Int64,
-    chunkSize :: Int
+    chunkSize :: Word32
   }
   deriving (Show)
 
@@ -150,11 +151,13 @@ downloadXFTPChunk c rpKey fId rKey =
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
 receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
-receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset} = liftIO $ do
-  withFile filePath AppendMode $ \h -> do
-    -- hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-    -- TODO chunk decryption
-    void $ receiveFile h chunkPart 0
+receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset, chunkSize} = do
+  withExceptT PCEResponseError . ExceptT $
+    withFile filePath AppendMode $ \h -> do
+      -- hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+      -- TODO chunk decryption
+      -- TODO delete chunk once it is saved to a separate file
+      receiveFile h chunkPart chunkSize
 
 -- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
 -- FDEL :: FileCommand Sender
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index a5f2b54bc..0305e7fc6 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -207,16 +207,17 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     noFile resp = pure (resp, Nothing)
     receiveServerFile :: FileRec -> M FileResponse
     receiveServerFile FileRec {senderId, fileInfo, filePath} = case bodyPart of
-      Nothing -> pure $ FRErr SIZE -- TODO file specific errors?
+      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
-        size' <- liftIO . withFile fPath WriteMode $ \h -> receiveFile h getBody 0
-        if size' == fromIntegral size -- TODO check digest
-          then atomically $ writeTVar filePath (Just fPath) $> FROk
-          else whenM (doesFileExist fPath) (removeFile fPath) $> FRErr SIZE
+        -- TODO check digest
+        liftIO $
+          withFile fPath WriteMode (\h -> receiveFile h getBody size) >>= \case
+            Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk
+            Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
       readTVarIO filePath >>= \case
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index 15fad7d4a..5405edc0e 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -14,29 +15,33 @@ import Control.Monad.Except
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Word (Word32)
 import GHC.IO.Handle.Internals (ioe_EOF)
-import Simplex.FileTransfer.Protocol (xftpBlockSize)
+import Simplex.FileTransfer.Protocol (XFTPErrorType (..), xftpBlockSize)
 import Simplex.Messaging.Version
 import System.IO (Handle)
 
 supportedFileServerVRange :: VersionRange
 supportedFileServerVRange = mkVersionRange 1 1
 
-sendFile :: Handle -> (Builder -> IO ()) -> Int -> IO ()
+sendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
 sendFile _ _ 0 = pure ()
 sendFile h send sz = do
   B.hGet h xftpBlockSize >>= \case
     "" -> when (sz /= 0) ioe_EOF
     ch -> do
-      let ch' = B.take sz ch -- sz >= xftpBlockSize
+      let ch' = B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
       send (byteString ch')
-      sendFile h send $ sz - B.length ch'
+      sendFile h send $ sz - fromIntegral (B.length ch')
 
--- TODO instead of receiving the whole file this function should stop at size and return error if file is larger
-receiveFile :: Handle -> (Int -> IO ByteString) -> Int -> IO Int
-receiveFile h receive sz = do
-  ch <- receive xftpBlockSize
-  let chSize = B.length ch
-  if chSize > 0
-    then B.hPut h ch >> receiveFile h receive (sz + chSize)
-    else pure sz
+receiveFile :: Handle -> (Int -> IO ByteString) -> Word32 -> IO (Either XFTPErrorType ())
+receiveFile h receive = go
+  where
+    go sz = do
+      ch <- receive xftpBlockSize
+      let chSize = fromIntegral $ B.length ch
+      if
+          | chSize > sz -> pure $ Left SIZE
+          | chSize > 0 -> B.hPut h ch >> go (sz - chSize)
+          | sz == 0 -> pure $ Right ()
+          | otherwise -> pure $ Left SIZE

From 2bf8cba4fd628556a72149df11494d1b2ae78e2a Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Feb 2023 20:56:46 +0000
Subject: [PATCH 15/71] xftp: download chunks to separate files

---
 src/Simplex/FileTransfer/Client.hs      | 19 ++++++------
 src/Simplex/FileTransfer/Client/Main.hs | 40 +++++++++++--------------
 tests/XFTPServerTests.hs                |  2 +-
 3 files changed, 29 insertions(+), 32 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index b8af2cf06..cd81a9483 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -14,6 +14,7 @@ import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Word (Word32)
@@ -41,7 +42,8 @@ import Simplex.Messaging.Transport (supportedParameters)
 import Simplex.Messaging.Transport.Client (TransportClientConfig)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
-import Simplex.Messaging.Util (bshow, liftEitherError)
+import Simplex.Messaging.Util (bshow, liftEitherError, whenM)
+import System.Directory (doesFileExist, removeFile)
 import System.IO (IOMode (..), SeekMode (..))
 import UnliftIO.IO (hSeek, withFile)
 
@@ -150,14 +152,13 @@ downloadXFTPChunk c rpKey fId rKey =
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
-receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset, chunkSize} = do
-  withExceptT PCEResponseError . ExceptT $
-    withFile filePath AppendMode $ \h -> do
-      -- hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-      -- TODO chunk decryption
-      -- TODO delete chunk once it is saved to a separate file
-      receiveFile h chunkPart chunkSize
+receiveXFTPChunk :: XFTPChunkBody -> FilePath -> Word32 -> ExceptT XFTPClientError IO ()
+receiveXFTPChunk XFTPChunkBody {chunkPart} filePath chunkSize = do
+  withExceptT PCEResponseError . ExceptT $ do
+    -- TODO chunk decryption
+    withFile filePath WriteMode (\h -> receiveFile h chunkPart chunkSize) >>= \case
+      Right () -> pure $ Right ()
+      Left e -> whenM (doesFileExist filePath) (removeFile filePath) $> Left e
 
 -- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
 -- FDEL :: FileCommand Sender
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 5d85d16fe..25d3edd73 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -330,39 +330,33 @@ cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} = do
   ValidFileDescription FileDescription {size, digest, key, nonce, chunks} <- getFileDescription fileDescription
   encPath <- getEncPath tempPath "xftp"
-  -- withFile encPath WriteMode $ \h -> do
-  --   liftIO $ LB.hPut h $ LB.replicate (unFileSize size) '#'
+  createDirectory encPath
   a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
-  writeLock <- atomically createLock
-  let chunkSizes = prepareChunkSizes $ unFileSize size
-      chunkSpecs = prepareChunkSpecs encPath chunkSizes
-  -- chunks have to be ordered because of AppendMode
-  forM_ (zip chunkSpecs chunks) $ \(chunkSpec, chunk) -> do
-    downloadFileChunk a writeLock chunk chunkSpec
-  encDigest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
+  chunkPaths <- pooledForConcurrentlyN 32 chunks $ downloadFileChunk a encPath
+  encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
   when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
-  path <- decryptFile encPath key nonce
-  whenM (doesFileExist encPath) $ removeFile encPath
+  path <- decryptFile chunkPaths key nonce
+  whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
   liftIO $ putStrLn $ "File received: " <> path
   where
     retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
     retries = withRetry retryCount . withExceptT (CLIError . show)
-    downloadFileChunk :: XFTPClientAgent -> Lock -> FileChunk -> XFTPChunkSpec -> ExceptT CLIError IO ()
-    downloadFileChunk a writeLock FileChunk {replicas = replica : _} chunkSpec = do
+    downloadFileChunk :: XFTPClientAgent -> FilePath -> FileChunk -> ExceptT CLIError IO FilePath
+    downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, replicas = replica : _} = do
       let FileChunkReplica {server, rcvId, rcvKey} = replica
+      chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- retries $ getXFTPServerClient a server
       (rKey, rpKey) <- liftIO C.generateKeyPair'
       (sKey, body) <- retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey
       -- download and decrypt (DH) chunk from server using XFTPClient
       -- verify chunk digest - in the client
-      -- save to correct location in file - also in the client
-      retries $ withLock writeLock "save" $ receiveXFTPChunk body chunkSpec
-    downloadFileChunk _ _ _ _ = pure ()
-    decryptFile :: FilePath -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
-    decryptFile encPath key nonce = do
-      f <- liftIO $ LB.readFile encPath
-      f' <- liftEither $ first (CLIError . show) $ LC.sbDecrypt key nonce f
-      let (fileHdr, f'') = LB.splitAt 1024 f'
+      retries $ receiveXFTPChunk body chunkPath $ unFileSize chunkSize
+      pure chunkPath
+    downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
+    decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
+    decryptFile chunkPaths key nonce = do
+      f <- liftEither . first (CLIError . show) . LC.sbDecrypt key nonce =<< liftIO (readChunks chunkPaths)
+      let (fileHdr, f') = LB.splitAt 1024 f
       -- withFile encPath ReadMode $ \r -> do
       --   fileHdr <- liftIO $ B.hGet r 1024
       case A.parse smpP $ LB.toStrict fileHdr of
@@ -370,8 +364,10 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
         A.Partial _ -> throwError $ CLIError "Invalid file header"
         A.Done rest FileHeader {fileName} -> do
           path <- getFilePath fileName
-          liftIO $ LB.writeFile path $ LB.fromStrict rest <> f''
+          liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
           pure path
+    readChunks :: [FilePath] -> IO LB.ByteString
+    readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) LB.empty
     getFilePath :: String -> ExceptT CLIError IO FilePath
     getFilePath name =
       case filePath of
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 7ea5719b5..fa7af00c1 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -52,6 +52,6 @@ testFileChunkDelivery =
       uploadXFTPChunk c spKey sId $ XFTPChunkSpec {filePath = "tests/tmp/chunk1", chunkOffset = 0, chunkSize = chSize}
       liftIO $ readChunk sId `shouldReturn` bytes
       (_sDhKey, chunkBody) <- downloadXFTPChunk c rpKey rId rDhKey
-      receiveXFTPChunk chunkBody XFTPChunkSpec {filePath = "tests/tmp/received_chunk1", chunkOffset = 0, chunkSize = chSize}
+      receiveXFTPChunk chunkBody "tests/tmp/received_chunk1" chSize
       liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
       pure ()

From 1ecef81b4de7a9695543705ff2e6b4831c72027e Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Feb 2023 22:44:44 +0000
Subject: [PATCH 16/71] xftp: validate digests of file chunks in client and
 server

---
 src/Simplex/FileTransfer/Client.hs      | 31 +++++++++++++++----------
 src/Simplex/FileTransfer/Client/Main.hs |  5 ++--
 src/Simplex/FileTransfer/Server.hs      | 16 +++++++++----
 src/Simplex/FileTransfer/Transport.hs   | 19 ++++++++-------
 tests/XFTPServerTests.hs                | 26 ++++++++++++++++-----
 5 files changed, 63 insertions(+), 34 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index cd81a9483..2e841c205 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -14,7 +14,7 @@ import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Word (Word32)
@@ -32,8 +32,10 @@ import Simplex.Messaging.Client
     transportClientConfig,
   )
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol
-  ( ProtocolServer (ProtocolServer),
+  ( Protocol (..),
+    ProtocolServer (..),
     RcvPublicDhKey,
     RecipientId,
     SenderId,
@@ -43,9 +45,8 @@ import Simplex.Messaging.Transport.Client (TransportClientConfig)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Util (bshow, liftEitherError, whenM)
-import System.Directory (doesFileExist, removeFile)
-import System.IO (IOMode (..), SeekMode (..))
-import UnliftIO.IO (hSeek, withFile)
+import UnliftIO.Directory
+import UnliftIO.IO
 
 data XFTPClient = XFTPClient
   { http2Client :: HTTP2Client,
@@ -110,7 +111,9 @@ sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fI
   -- 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 -> pure (r, body)
+    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 ()
@@ -152,13 +155,17 @@ downloadXFTPChunk c rpKey fId rKey =
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-receiveXFTPChunk :: XFTPChunkBody -> FilePath -> Word32 -> ExceptT XFTPClientError IO ()
-receiveXFTPChunk XFTPChunkBody {chunkPart} filePath chunkSize = do
-  withExceptT PCEResponseError . ExceptT $ do
+receiveXFTPChunk :: XFTPChunkBody -> FilePath -> Word32 -> ByteString -> ExceptT XFTPClientError IO ()
+receiveXFTPChunk XFTPChunkBody {chunkPart} filePath chunkSize chunkDigest = do
+  withExceptT PCEResponseError $ do
     -- TODO chunk decryption
-    withFile filePath WriteMode (\h -> receiveFile h chunkPart chunkSize) >>= \case
-      Right () -> pure $ Right ()
-      Left e -> whenM (doesFileExist filePath) (removeFile filePath) $> Left e
+    receiveChunk `catchError` \e ->
+      whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
+  where
+    receiveChunk = do
+      ExceptT . withFile filePath WriteMode $ \h -> receiveFile h chunkPart chunkSize
+      digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
+      when (digest' /= chunkDigest) $ throwError DIGEST
 
 -- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
 -- FDEL :: FileCommand Sender
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 25d3edd73..3e9479f94 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -342,7 +342,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
     retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
     retries = withRetry retryCount . withExceptT (CLIError . show)
     downloadFileChunk :: XFTPClientAgent -> FilePath -> FileChunk -> ExceptT CLIError IO FilePath
-    downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, replicas = replica : _} = do
+    downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
       let FileChunkReplica {server, rcvId, rcvKey} = replica
       chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- retries $ getXFTPServerClient a server
@@ -350,7 +350,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       (sKey, body) <- retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey
       -- download and decrypt (DH) chunk from server using XFTPClient
       -- verify chunk digest - in the client
-      retries $ receiveXFTPChunk body chunkPath $ unFileSize chunkSize
+      retries $ receiveXFTPChunk body chunkPath (unFileSize chunkSize) (unFileDigest digest)
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
@@ -368,6 +368,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
           pure path
     readChunks :: [FilePath] -> IO LB.ByteString
     readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) LB.empty
+    {-# NOINLINE readChunks #-}
     getFilePath :: String -> ExceptT CLIError IO FilePath
     getFilePath name =
       case filePath of
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 0305e7fc6..d6f40b8e9 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -21,6 +21,7 @@ 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 qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
 import Data.List (intercalate)
 import qualified Data.List.NonEmpty as L
@@ -36,6 +37,7 @@ import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Transport (receiveFile, sendFile)
 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)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
@@ -147,7 +149,6 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
   where
     sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
     sendXFTPResponse (corrId, fId, resp) serverFile_ = do
-      -- liftIO . sendResponse . H.responseBuilder N.ok200 [] . byteString $
       let t_ = xftpEncodeTransmission sessionId Nothing (corrId, fId, resp)
       liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
       where
@@ -157,7 +158,7 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
             Right t -> do
               send $ byteString t
               -- TODO chunk encryption
-              forM_ serverFile_ $ \ServerFile {filePath, fileSize, fileDhSecret} -> do
+              forM_ serverFile_ $ \ServerFile {filePath, fileSize, fileDhSecret} ->
                 withFile filePath ReadMode $ \h -> sendFile h send $ fromIntegral fileSize
           done
 
@@ -207,17 +208,22 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     noFile resp = pure (resp, Nothing)
     receiveServerFile :: FileRec -> M FileResponse
     receiveServerFile FileRec {senderId, fileInfo, filePath} = 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
-        -- TODO check digest
         liftIO $
-          withFile fPath WriteMode (\h -> receiveFile h getBody size) >>= \case
+          runExceptT (receiveChunk fPath fileInfo) >>= \case
             Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk
             Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
+        where
+          receiveChunk fPath FileInfo {size, digest} = do
+            ExceptT . withFile fPath WriteMode $ \h -> receiveFile h getBody size
+            digest' <- liftIO $ LC.sha512Hash <$> LB.readFile fPath
+            when (digest' /= digest) $ throwError DIGEST
+
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
       readTVarIO filePath >>= \case
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index 5405edc0e..62736f4c3 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -11,7 +11,6 @@ module Simplex.FileTransfer.Transport
   )
 where
 
-import Control.Monad.Except
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -25,14 +24,16 @@ supportedFileServerVRange :: VersionRange
 supportedFileServerVRange = mkVersionRange 1 1
 
 sendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
-sendFile _ _ 0 = pure ()
-sendFile h send sz = do
-  B.hGet h xftpBlockSize >>= \case
-    "" -> when (sz /= 0) ioe_EOF
-    ch -> do
-      let ch' = B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
-      send (byteString ch')
-      sendFile h send $ sz - fromIntegral (B.length ch')
+sendFile h send = go
+  where
+    go 0 = pure ()
+    go sz =
+      B.hGet h xftpBlockSize >>= \case
+        "" -> ioe_EOF
+        ch -> do
+          let ch' = B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
+          send $ byteString ch'
+          go $ sz - fromIntegral (B.length ch')
 
 receiveFile :: Handle -> (Int -> IO ByteString) -> Word32 -> IO (Either XFTPErrorType ())
 receiveFile h receive = go
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index fa7af00c1..07422a49b 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -6,14 +6,17 @@
 module XFTPServerTests where
 
 import AgentTests.FunctionalAPITests (runRight_)
-import Control.Monad.IO.Class (liftIO)
+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 Simplex.FileTransfer.Client
-import Simplex.FileTransfer.Protocol (FileInfo (..))
+import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..))
+import Simplex.Messaging.Client (ProtocolClientError (..))
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol (SenderId)
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.FilePath ((</>))
@@ -30,6 +33,9 @@ xftpServerTests =
 chSize :: Num n => n
 chSize = 256 * 1024
 
+testChunkPath :: FilePath
+testChunkPath = "tests/tmp/chunk1"
+
 createTestChunk :: FilePath -> IO ByteString
 createTestChunk fp = do
   bytes <- getRandomBytes chSize
@@ -45,13 +51,21 @@ testFileChunkDelivery =
     (sndKey, spKey) <- C.generateSignatureKeyPair C.SEd25519
     (rcvKey, rpKey) <- C.generateSignatureKeyPair C.SEd25519
     (rDhKey, _rpDhKey) <- C.generateKeyPair'
-    bytes <- createTestChunk "tests/tmp/chunk1"
+    bytes <- createTestChunk testChunkPath
     xftpTest $ \c -> runRight_ $ do
-      let file = FileInfo {sndKey, size = chSize, digest = "abc="}
+      digest <- liftIO $ LC.sha512Hash <$> 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]
-      uploadXFTPChunk c spKey sId $ XFTPChunkSpec {filePath = "tests/tmp/chunk1", chunkOffset = 0, chunkSize = chSize}
+      uploadXFTPChunk c spKey sId chunkSpec
+      (sId', _) <- createXFTPChunk c spKey file {digest = digest <> "_wrong"} [rcvKey]
+      uploadXFTPChunk c spKey sId' chunkSpec
+        `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
       liftIO $ readChunk sId `shouldReturn` bytes
       (_sDhKey, chunkBody) <- downloadXFTPChunk c rpKey rId rDhKey
-      receiveXFTPChunk chunkBody "tests/tmp/received_chunk1" chSize
+      receiveXFTPChunk chunkBody "tests/tmp/received_chunk1" chSize (digest <> "_wrong")
+        `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
+      (_sDhKey, chunkBody') <- downloadXFTPChunk c rpKey rId rDhKey
+      receiveXFTPChunk chunkBody' "tests/tmp/received_chunk1" chSize digest
       liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
       pure ()

From 4a9b5412db11d2b4f21d61196ad5097f5a7f8805 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Feb 2023 23:21:59 +0000
Subject: [PATCH 17/71] xftp: refactor

---
 src/Simplex/FileTransfer/Client.hs      | 31 ++++++++-----------------
 src/Simplex/FileTransfer/Client/Main.hs |  8 +++----
 src/Simplex/FileTransfer/Server.hs      | 12 +++-------
 src/Simplex/FileTransfer/Transport.hs   | 27 ++++++++++++++++-----
 tests/XFTPServerTests.hs                |  7 +++---
 5 files changed, 40 insertions(+), 45 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 2e841c205..6de183aa9 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -14,14 +14,13 @@ import Data.Bifunctor (first)
 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.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Word (Word32)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
 import Simplex.FileTransfer.Protocol
-import Simplex.FileTransfer.Transport (receiveFile, sendFile)
+import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
     ProtocolClientError (..),
@@ -32,7 +31,6 @@ import Simplex.Messaging.Client
     transportClientConfig,
   )
 import qualified Simplex.Messaging.Crypto as C
-import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol
   ( Protocol (..),
     ProtocolServer (..),
@@ -144,29 +142,20 @@ uploadXFTPChunk c spKey fId chunkSpec =
     (FROk, _body) -> pure ()
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> ExceptT XFTPClientError IO (RcvPublicDhKey, XFTPChunkBody)
-downloadXFTPChunk c rpKey fId rKey =
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
+downloadXFTPChunk c rpKey fId rKey chunkSpec@XFTPRcvChunkSpec {filePath} =
   sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case
-    (FRFile sKey, http2Body@HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
-      -- TODO atm bodySize is set to 0, so chunkSize will be incorrect
+    (FRFile sKey, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+      -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
       Just chunkPart -> do
-        let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body}
-        pure (sKey, chunk)
+        -- let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body}
+        withExceptT PCEResponseError $ do
+          -- TODO chunk decryption
+          receiveFile chunkPart chunkSpec `catchError` \e ->
+            whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-receiveXFTPChunk :: XFTPChunkBody -> FilePath -> Word32 -> ByteString -> ExceptT XFTPClientError IO ()
-receiveXFTPChunk XFTPChunkBody {chunkPart} filePath chunkSize chunkDigest = do
-  withExceptT PCEResponseError $ do
-    -- TODO chunk decryption
-    receiveChunk `catchError` \e ->
-      whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
-  where
-    receiveChunk = do
-      ExceptT . withFile filePath WriteMode $ \h -> receiveFile h chunkPart chunkSize
-      digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
-      when (digest' /= chunkDigest) $ throwError DIGEST
-
 -- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
 -- FDEL :: FileCommand Sender
 -- FACK :: FileCommand Recipient
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 3e9479f94..2641b8526 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -29,7 +29,7 @@ import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Client.Agent
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileInfo (..))
-import Simplex.Messaging.Agent.Lock
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
@@ -347,10 +347,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- retries $ getXFTPServerClient a server
       (rKey, rpKey) <- liftIO C.generateKeyPair'
-      (sKey, body) <- retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey
-      -- download and decrypt (DH) chunk from server using XFTPClient
-      -- verify chunk digest - in the client
-      retries $ receiveXFTPChunk body chunkPath (unFileSize chunkSize) (unFileDigest digest)
+      let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
+      retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index d6f40b8e9..9e9085450 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -21,7 +21,6 @@ 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 qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
 import Data.List (intercalate)
 import qualified Data.List.NonEmpty as L
@@ -35,9 +34,8 @@ import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Server.Env
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
-import Simplex.FileTransfer.Transport (receiveFile, sendFile)
+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)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
@@ -214,15 +212,11 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         -- 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
         liftIO $
-          runExceptT (receiveChunk fPath fileInfo) >>= \case
+          runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
             Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk
             Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
-        where
-          receiveChunk fPath FileInfo {size, digest} = do
-            ExceptT . withFile fPath WriteMode $ \h -> receiveFile h getBody size
-            digest' <- liftIO $ LC.sha512Hash <$> LB.readFile fPath
-            when (digest' /= digest) $ throwError DIGEST
 
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index 62736f4c3..e6f4fbdd3 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -1,24 +1,36 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
+    XFTPRcvChunkSpec (..),
     sendFile,
     receiveFile,
   )
 where
 
+import Control.Monad.Except
 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 (..), xftpBlockSize)
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Version
-import System.IO (Handle)
+import System.IO (Handle, IOMode (..), withFile)
+
+data XFTPRcvChunkSpec = XFTPRcvChunkSpec
+  { filePath :: FilePath,
+    chunkSize :: Word32,
+    chunkDigest :: ByteString
+  }
+  deriving (Show)
 
 supportedFileServerVRange :: VersionRange
 supportedFileServerVRange = mkVersionRange 1 1
@@ -35,14 +47,17 @@ sendFile h send = go
           send $ byteString ch'
           go $ sz - fromIntegral (B.length ch')
 
-receiveFile :: Handle -> (Int -> IO ByteString) -> Word32 -> IO (Either XFTPErrorType ())
-receiveFile h receive = go
+receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
+receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
+  ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
+  digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
+  when (digest' /= chunkDigest) $ throwError DIGEST
   where
-    go sz = do
-      ch <- receive xftpBlockSize
+    receive h sz = do
+      ch <- getBody xftpBlockSize
       let chSize = fromIntegral $ B.length ch
       if
           | chSize > sz -> pure $ Left SIZE
-          | chSize > 0 -> B.hPut h ch >> go (sz - chSize)
+          | chSize > 0 -> B.hPut h ch >> receive h (sz - chSize)
           | sz == 0 -> pure $ Right ()
           | otherwise -> pure $ Left SIZE
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 07422a49b..0e3b4715c 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..))
+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
@@ -62,10 +63,8 @@ testFileChunkDelivery =
       uploadXFTPChunk c spKey sId' chunkSpec
         `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
       liftIO $ readChunk sId `shouldReturn` bytes
-      (_sDhKey, chunkBody) <- downloadXFTPChunk c rpKey rId rDhKey
-      receiveXFTPChunk chunkBody "tests/tmp/received_chunk1" chSize (digest <> "_wrong")
+      downloadXFTPChunk c rpKey rId rDhKey (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
         `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
-      (_sDhKey, chunkBody') <- downloadXFTPChunk c rpKey rId rDhKey
-      receiveXFTPChunk chunkBody' "tests/tmp/received_chunk1" chSize digest
+      downloadXFTPChunk c rpKey rId rDhKey $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
       liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
       pure ()

From c970674452b168d7a681b7c83c7b4dcbd734fa64 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sun, 19 Feb 2023 10:54:54 +0000
Subject: [PATCH 18/71] faster lazy secret_box

---
 src/Simplex/FileTransfer/Client/Main.hs | 10 +--
 src/Simplex/Messaging/Crypto/Lazy.hs    | 81 +++++++++++++++----------
 2 files changed, 55 insertions(+), 36 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 2641b8526..a5681ffa5 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -231,18 +231,18 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
           chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + cbAuthTagLen
-          paddedSize = fromIntegral $ sum chunkSizes
-      encrypt fileHdr key nonce fileSize' paddedSize encPath
+          encSize = fromIntegral $ sum chunkSizes
+      encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
-          fd = FileDescription {size = FileSize paddedSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
+          fd = FileDescription {size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
       pure (encPath, fd, chunkSpecs)
       where
         encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
-        encrypt fileHdr key nonce fileSize' paddedSize encFile = do
+        encrypt fileHdr key nonce fileSize' encSize encFile = do
           f <- liftIO $ LB.readFile filePath
           let f' = LB.fromStrict fileHdr <> f
-          c <- liftEither $ first (CLIError . show) $ LC.sbEncrypt key nonce f' fileSize' $ paddedSize - cbAuthTagLen
+          c <- liftEither $ first (CLIError . show) $ LC.sbEncrypt key nonce f' fileSize' $ encSize - cbAuthTagLen
           liftIO $ LB.writeFile encFile c
     -- let padSize = paddedSize - fileSize - fromIntegral (B.length fileHdr)
     -- when (padSize > 0) . LB.hPut h $ LB.replicate padSize '#'
diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs
index 667c9a7c4..68f3326e4 100644
--- a/src/Simplex/Messaging/Crypto/Lazy.hs
+++ b/src/Simplex/Messaging/Crypto/Lazy.hs
@@ -1,5 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Crypto.Lazy
   ( sha512Hash,
@@ -18,10 +21,13 @@ import Crypto.Hash.Algorithms (SHA512)
 import qualified Crypto.MAC.Poly1305 as Poly1305
 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.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
 import Foreign (sizeOf)
 import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), SbKey, pattern CbNonce, pattern SbKey)
 import Simplex.Messaging.Encoding
@@ -68,51 +74,64 @@ unPad padded
 
 -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce.
 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.
 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
+    process state = foldlChunks update ([], state) msg
+    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
+    run state = let (cs, state') = process state in BA.convert (sbAuth state') :| reverse cs
 
-poly1305auth :: ByteString -> LazyByteString -> Either CryptoError Poly1305.Auth
-poly1305auth rs c = authTag <$> cryptoPassed (Poly1305.initialize rs)
-  where
-    authTag state = Poly1305.finalize $ Poly1305.updates state $ LB.toChunks c
-    cryptoPassed = \case
-      CE.CryptoPassed a -> Right a
-      CE.CryptoFailed e -> Left $ CryptoPoly1305Error e
+type SbState = (XSalsa.State, Poly1305.State)
 
-xSalsa20 :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> (ByteString, LazyByteString)
-xSalsa20 secret nonce msg = (rs, msg')
+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
+
+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 #-}

From 50664930cc7e257f5d72c33addb535a1304a915c Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 20 Feb 2023 12:41:15 +0000
Subject: [PATCH 19/71] xftp: tests with 2 servers and 2 clients

---
 tests/XFTPCLI.hs         | 27 ++++++++++++++++++++-
 tests/XFTPServerTests.hs | 51 ++++++++++++++++++++++------------------
 2 files changed, 54 insertions(+), 24 deletions(-)

diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index dd7897d67..57737aaf9 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -8,11 +8,12 @@ import System.Environment (withArgs)
 import System.FilePath ((</>))
 import System.IO.Silently (capture_)
 import Test.Hspec
-import XFTPClient (testXFTPServerStr, withXFTPServer, xftpServerFiles, xftpServerFiles2)
+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
 
 testBracket :: IO () -> IO ()
 testBracket =
@@ -51,3 +52,27 @@ testXFTPCLISendReceive = withXFTPServer $ do
       xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
         `shouldReturn` ["File received: " <> recipientFiles </> fileName]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
+
+testXFTPCLISendReceive2servers :: IO ()
+testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
+  let filePath = senderFiles </> "testfile"
+  xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` 19 * mb
+  let fd1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fd2 = filePath <> ".xftp" </> "rcv2.xftp"
+  xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+    `shouldReturn` ["File uploaded!", "Pass file descriptions to the recipient(s):", fd1, fd2]
+  testReceiveFile fd1 "testfile" file
+  testReceiveFile fd2 "testfile_1" file
+  where
+    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
+    testReceiveFile fd fileName file = do
+      [sizeStr, srvStr, srv1Str, srv2Str] <- xftp ["info", fd]
+      sizeStr `shouldBe` "File download size: 20mb"
+      srvStr `shouldBe` "File server(s):"
+      srv1Str `shouldContain` testXFTPServerStr
+      srv2Str `shouldContain` testXFTPServerStr2
+      xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+        `shouldReturn` ["File received: " <> recipientFiles </> fileName]
+      LB.readFile (recipientFiles </> fileName) `shouldReturn` file
\ No newline at end of file
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 0e3b4715c..42fdd28b1 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -29,7 +29,9 @@ xftpServerTests =
   before_ (createDirectoryIfMissing False xftpServerFiles)
     . after_ (removeDirectoryRecursive xftpServerFiles)
     $ do
-      describe "XFTP file chunk delivery" testFileChunkDelivery
+      describe "XFTP file chunk delivery" $ do
+        it "should create, upload and receive file chunk" testFileChunkDelivery
+        it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
 
 chSize :: Num n => n
 chSize = 256 * 1024
@@ -46,25 +48,28 @@ createTestChunk fp = do
 readChunk :: SenderId -> IO ByteString
 readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))
 
-testFileChunkDelivery :: Spec
-testFileChunkDelivery =
-  it "should create, upload and receive file chunk" $ do
-    (sndKey, spKey) <- C.generateSignatureKeyPair C.SEd25519
-    (rcvKey, rpKey) <- C.generateSignatureKeyPair C.SEd25519
-    (rDhKey, _rpDhKey) <- C.generateKeyPair'
-    bytes <- createTestChunk testChunkPath
-    xftpTest $ \c -> runRight_ $ do
-      digest <- liftIO $ LC.sha512Hash <$> 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]
-      uploadXFTPChunk c spKey sId chunkSpec
-      (sId', _) <- createXFTPChunk c spKey file {digest = digest <> "_wrong"} [rcvKey]
-      uploadXFTPChunk c spKey sId' chunkSpec
-        `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
-      liftIO $ readChunk sId `shouldReturn` bytes
-      downloadXFTPChunk c rpKey rId rDhKey (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
-        `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
-      downloadXFTPChunk c rpKey rId rDhKey $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
-      liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
-      pure ()
+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
+  (rDhKey, _rpDhKey) <- liftIO C.generateKeyPair'
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha512Hash <$> 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]
+  uploadXFTPChunk s spKey sId chunkSpec
+  (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey]
+  uploadXFTPChunk s spKey sId' chunkSpec
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
+  liftIO $ readChunk sId `shouldReturn` bytes
+  downloadXFTPChunk r rpKey rId rDhKey (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
+    `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
+  downloadXFTPChunk r rpKey rId rDhKey $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes

From bbf9e28696515a8e3269319ee32fbba0f0fec853 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 22 Feb 2023 09:03:18 +0000
Subject: [PATCH 20/71] xftp: add server to client encryption layer with
 cryptobox (#646)

* xftp: add server to client encryption layer with cryptobox

* workarounds for http2

* update http2 commit

* remove TODOs
---
 cabal.project                                 |  2 +-
 src/Simplex/FileTransfer/Client.hs            | 19 ++---
 src/Simplex/FileTransfer/Client/Main.hs       |  5 +-
 src/Simplex/FileTransfer/Protocol.hs          |  8 +--
 src/Simplex/FileTransfer/Server.hs            | 28 ++++----
 src/Simplex/FileTransfer/Transport.hs         | 71 ++++++++++++++++---
 src/Simplex/Messaging/Agent/Client.hs         |  2 +-
 src/Simplex/Messaging/Client.hs               |  4 +-
 src/Simplex/Messaging/Crypto/Lazy.hs          | 18 +++--
 src/Simplex/Messaging/Notifications/Server.hs |  2 +-
 .../Notifications/Server/Push/APNS.hs         |  2 +-
 tests/AgentTests.hs                           |  2 -
 tests/AgentTests/SQLiteTests.hs               |  4 --
 tests/XFTPCLI.hs                              | 11 ++-
 tests/XFTPServerTests.hs                      |  7 +-
 15 files changed, 124 insertions(+), 61 deletions(-)

diff --git a/cabal.project b/cabal.project
index 9ec665d9f..1b036aa86 100644
--- a/cabal.project
+++ b/cabal.project
@@ -15,7 +15,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kazu-yamamoto/http2.git
-    tag: 1136bb126636789cec197e5d0bae39aa63c6f9e5
+    tag: aa56ded3494dd4f0efb0bbcb5378879ce785a647
 
 source-repository-package
     type: git
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 6de183aa9..38916aa31 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -31,10 +31,10 @@ import Simplex.Messaging.Client
     transportClientConfig,
   )
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol
   ( Protocol (..),
     ProtocolServer (..),
-    RcvPublicDhKey,
     RecipientId,
     SenderId,
   )
@@ -142,16 +142,17 @@ uploadXFTPChunk c spKey fId chunkSpec =
     (FROk, _body) -> pure ()
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
-downloadXFTPChunk c rpKey fId rKey chunkSpec@XFTPRcvChunkSpec {filePath} =
-  sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case
-    (FRFile sKey, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
+downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
+  (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
+  sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
+    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
       -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
       Just chunkPart -> do
-        -- let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body}
-        withExceptT PCEResponseError $ do
-          -- TODO chunk decryption
-          receiveFile chunkPart chunkSpec `catchError` \e ->
+        let dhSecret = C.dh' sDhKey rpDhKey
+        cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
+        withExceptT PCEResponseError $
+          receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
             whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index a5681ffa5..4e74a5659 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -332,7 +332,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
   encPath <- getEncPath tempPath "xftp"
   createDirectory encPath
   a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
-  chunkPaths <- pooledForConcurrentlyN 32 chunks $ downloadFileChunk a encPath
+  chunkPaths <- forM chunks $ downloadFileChunk a encPath
   encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
   when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
   path <- decryptFile chunkPaths key nonce
@@ -346,9 +346,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       let FileChunkReplica {server, rcvId, rcvKey} = replica
       chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- retries $ getXFTPServerClient a server
-      (rKey, rpKey) <- liftIO C.generateKeyPair'
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey chunkSpec
+      retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 3353e0e26..0fe36d41f 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -251,7 +251,7 @@ instance ProtocolMsgTag FileResponseTag where
 data FileResponse
   = FRSndIds SenderId (NonEmpty RecipientId)
   | FRRcvIds (NonEmpty RecipientId)
-  | FRFile RcvPublicDhKey
+  | FRFile RcvPublicDhKey C.CbNonce
   | FROk
   | FRErr XFTPErrorType
   | FRPong
@@ -262,7 +262,7 @@ instance ProtocolEncoding XFTPErrorType FileResponse where
   encodeProtocol _v = \case
     FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
     FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
-    FRFile rKey -> e (FRFile_, ' ', rKey)
+    FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
     FROk -> e FROk_
     FRErr err -> e (FRErr_, ' ', err)
     FRPong -> e FRPong_
@@ -273,7 +273,7 @@ instance ProtocolEncoding XFTPErrorType FileResponse where
   protocolP _v = \case
     FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
     FRRcvIds_ -> FRRcvIds <$> _smpP
-    FRFile_ -> FRFile <$> _smpP
+    FRFile_ -> FRFile <$> _smpP <*> smpP
     FROk_ -> pure FROk
     FRErr_ -> FRErr <$> _smpP
     FRPong_ -> pure FRPong
@@ -313,7 +313,7 @@ data XFTPErrorType
     SIZE
   | -- | incorrent file digest
     DIGEST
-  | -- | no file body
+  | -- | no expected file body in request/response or no file on the server
     NO_FILE
   | -- | unexpected file body
     HAS_FILE
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 9e9085450..4c1291a21 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -36,6 +36,7 @@ import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 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)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
@@ -122,11 +123,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
               ]
         threadDelay interval
 
--- TODO add client DH secret
 data ServerFile = ServerFile
   { filePath :: FilePath,
     fileSize :: Word32,
-    fileDhSecret :: C.DhSecretX25519
+    sbState :: LC.SbState
   }
 
 processRequest :: HTTP2Request -> M ()
@@ -152,12 +152,13 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
       where
         streamBody t_ send done = do
           case t_ of
-            Left _ -> send "padding error" -- TODO respond with BLOCK error?
+            Left _ -> do
+              send "padding error" -- TODO respond with BLOCK error?
+              done
             Right t -> do
               send $ byteString t
-              -- TODO chunk encryption
-              forM_ serverFile_ $ \ServerFile {filePath, fileSize, fileDhSecret} ->
-                withFile filePath ReadMode $ \h -> sendFile h send $ fromIntegral fileSize
+              forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do
+                withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize)
           done
 
 data VerificationResult = VRVerified XFTPRequest | VRFailed
@@ -196,7 +197,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     FADD _rcps -> noFile FROk
     FPUT -> (,Nothing) <$> receiveServerFile fr
     FDEL -> noFile FROk
-    FGET dhKey -> sendServerFile fr dhKey
+    FGET rDhKey -> sendServerFile fr rDhKey
     FACK -> noFile FROk
     -- it should never get to the options below, they are passed in other constructors of XFTPRequest
     FNEW _ _ -> noFile $ FRErr INTERNAL
@@ -219,13 +220,16 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
             Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
 
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
-    sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do
+    sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rDhKey = do
       readTVarIO filePath >>= \case
         Just path -> do
-          (sKey, spKey) <- liftIO C.generateKeyPair'
-          let fileDhSecret = C.dh' rKey spKey
-          pure (FRFile sKey, Just ServerFile {filePath = path, fileSize = size, fileDhSecret})
-        _ -> pure (FRErr AUTH, Nothing) -- TODO file-specific errors?
+          (sDhKey, spDhKey) <- liftIO C.generateKeyPair'
+          let dhSecret = C.dh' rDhKey spDhKey
+          cbNonce <- liftIO C.randomCbNonce
+          pure $ case LC.cbInit dhSecret cbNonce of
+            Right sbState -> (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
+            _ -> (FRErr INTERNAL, Nothing)
+        _ -> pure (FRErr NO_FILE, Nothing)
 
 randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
 randomId n = do
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index e6f4fbdd3..a57848d62 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -10,10 +10,15 @@ module Simplex.FileTransfer.Transport
     XFTPRcvChunkSpec (..),
     sendFile,
     receiveFile,
+    sendEncFile,
+    receiveEncFile,
   )
 where
 
+import Control.Concurrent (threadDelay)
+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
@@ -21,6 +26,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Word (Word32)
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Simplex.FileTransfer.Protocol (XFTPErrorType (..), xftpBlockSize)
+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)
@@ -40,18 +46,33 @@ sendFile h send = go
   where
     go 0 = pure ()
     go sz =
-      B.hGet h xftpBlockSize >>= \case
-        "" -> ioe_EOF
-        ch -> do
-          let ch' = B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
-          send $ byteString ch'
-          go $ sz - fromIntegral (B.length ch')
+      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
+      -- TODO remove padding when HTTP2 issue is fixed
+      let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (xftpBlockSize - C.authTagSize) '#'
+      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
+        -- TODO remove delay when HTTP2 issue is fixed
+        threadDelay 500
+        go sbState' $ sz - fromIntegral (B.length ch)
+
+getFileChunk :: Handle -> Word32 -> IO ByteString
+getFileChunk h sz =
+  B.hGet h xftpBlockSize >>= \case
+    "" -> ioe_EOF
+    ch -> pure $ B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
 
 receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
-receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
-  ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
-  digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath
-  when (digest' /= chunkDigest) $ throwError DIGEST
+receiveFile getBody = receiveFile_ receive
   where
     receive h sz = do
       ch <- getBody xftpBlockSize
@@ -61,3 +82,33 @@ receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
           | 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 xftpBlockSize
+      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 DIGEST
+          | 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.sha512Hash <$> LB.readFile filePath
+  when (digest' /= chunkDigest) $ throwError DIGEST
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 2332d0fc9..dbc22684d 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -592,7 +592,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
diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index f4f39db39..b4d633860 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -414,8 +414,8 @@ 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)
diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs
index 68f3326e4..cb1d40aac 100644
--- a/src/Simplex/Messaging/Crypto/Lazy.hs
+++ b/src/Simplex/Messaging/Crypto/Lazy.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -11,6 +12,11 @@ module Simplex.Messaging.Crypto.Lazy
     sbEncrypt,
     sbDecrypt,
     fastReplicate,
+    SbState,
+    cbInit,
+    sbEncryptChunk,
+    sbDecryptChunk,
+    sbAuth,
   )
 where
 
@@ -29,7 +35,7 @@ import qualified Data.ByteString.Lazy.Internal as LB
 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
@@ -92,7 +98,7 @@ sbDecrypt (SbKey key) (CbNonce nonce) packet
     (tag', c) = LB.splitAt 16 packet
 
 secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString)
-secretBox sbProcess secret nonce msg = run <$> sbInit secret nonce
+secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
     process state = foldlChunks update ([], state) msg
     update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
@@ -100,8 +106,12 @@ secretBox sbProcess secret nonce msg = run <$> sbInit secret nonce
 
 type SbState = (XSalsa.State, Poly1305.State)
 
-sbInit :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState
-sbInit secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
+cbInit :: DhSecretX25519 -> CbNonce -> Either CryptoError SbState
+cbInit (DhSecretX25519 secret) (CbNonce nonce) = sbInit_ secret nonce
+{-# INLINE cbInit #-}
+
+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
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index bbc7e3d43..1f230883b 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/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 ()
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index 32f92c6aa..ae4e3453d 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -343,7 +343,7 @@ 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
-  -- TODO if HTTP2 client is thread-safe, we can use sendRequestDirect (the tests pass)
+  -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
   HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req
   let status = H.responseStatus response
       reason' = maybe "" reason $ J.decodeStrict' bodyHead
diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs
index 705bf4550..77c61004e 100644
--- a/tests/AgentTests.hs
+++ b/tests/AgentTests.hs
@@ -499,10 +499,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
diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs
index a43196148..6c3d6c80b 100644
--- a/tests/AgentTests/SQLiteTests.hs
+++ b/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
 
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 57737aaf9..5897c4b0b 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -2,6 +2,7 @@ module XFTPCLI where
 
 import Control.Exception (bracket_)
 import qualified Data.ByteString as LB
+import Data.List (isInfixOf)
 import Simplex.FileTransfer.Client.Main (xftpClientCLI)
 import System.Directory (createDirectoryIfMissing, getFileSize, removeDirectoryRecursive)
 import System.Environment (withArgs)
@@ -68,11 +69,15 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   where
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testReceiveFile fd fileName file = do
-      [sizeStr, srvStr, srv1Str, srv2Str] <- xftp ["info", fd]
+      sizeStr : srvStr : srvs <- xftp ["info", fd]
       sizeStr `shouldBe` "File download size: 20mb"
       srvStr `shouldBe` "File server(s):"
-      srv1Str `shouldContain` testXFTPServerStr
-      srv2Str `shouldContain` testXFTPServerStr2
+      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"
       xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
         `shouldReturn` ["File received: " <> recipientFiles </> fileName]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
\ No newline at end of file
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 42fdd28b1..429973c7b 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -34,7 +34,7 @@ xftpServerTests =
         it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
 
 chSize :: Num n => n
-chSize = 256 * 1024
+chSize = 128 * 1024
 
 testChunkPath :: FilePath
 testChunkPath = "tests/tmp/chunk1"
@@ -58,7 +58,6 @@ runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError
 runTestFileChunkDelivery s r = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  (rDhKey, _rpDhKey) <- liftIO C.generateKeyPair'
   bytes <- liftIO $ createTestChunk testChunkPath
   digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
   let file = FileInfo {sndKey, size = chSize, digest}
@@ -69,7 +68,7 @@ runTestFileChunkDelivery s r = do
   uploadXFTPChunk s spKey sId' chunkSpec
     `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
   liftIO $ readChunk sId `shouldReturn` bytes
-  downloadXFTPChunk r rpKey rId rDhKey (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
     `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
-  downloadXFTPChunk r rpKey rId rDhKey $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes

From 97b8b37325c313e4551fd6455653b80231b1ca4c Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 22 Feb 2023 12:32:30 +0000
Subject: [PATCH 21/71] xftp: FDEL and FACK commands (#648)

* xftp: FDEL and FACK commands

* correction

* more tests

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Client.hs       | 25 +++++++---
 src/Simplex/FileTransfer/Protocol.hs     |  4 ++
 src/Simplex/FileTransfer/Server.hs       | 32 +++++++++---
 src/Simplex/FileTransfer/Server/Env.hs   |  4 +-
 src/Simplex/FileTransfer/Server/Store.hs |  6 +++
 tests/XFTPServerTests.hs                 | 63 +++++++++++++++++++++++-
 6 files changed, 118 insertions(+), 16 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 38916aa31..5c9a475cf 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -131,16 +131,12 @@ createXFTPChunk ::
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
 createXFTPChunk c spKey file rsps =
   sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
-    -- TODO check that body is empty
-    (FRSndIds sId rIds, _body) -> pure (sId, rIds)
+    (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) >>= \case
-    -- TODO check that body is empty
-    (FROk, _body) -> pure ()
-    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+  sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
 downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
 downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
@@ -157,6 +153,23 @@ downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
       _ -> 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
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 0fe36d41f..56fd9be32 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -317,6 +317,8 @@ data XFTPErrorType
     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)
@@ -333,6 +335,7 @@ instance Encoding XFTPErrorType where
     DIGEST -> "DIGEST"
     NO_FILE -> "NO_FILE"
     HAS_FILE -> "HAS_FILE"
+    FILE_IO -> "FILE_IO"
     INTERNAL -> "INTERNAL"
     DUPLICATE_ -> "DUPLICATE_"
 
@@ -346,6 +349,7 @@ instance Encoding XFTPErrorType where
       "DIGEST" -> pure DIGEST
       "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"
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 4c1291a21..6fd8aa148 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -17,6 +17,7 @@ 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)
@@ -38,7 +39,7 @@ 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)
+import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
@@ -176,7 +177,7 @@ verifyXFTPTransmission sig_ signed fId cmd =
       atomically $ verify <$> getFile st party fId
       where
         verify = \case
-          Right (fr, k) -> XFTPReqCmd fr cmd `verifyWith` k
+          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
 
@@ -193,12 +194,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       forM (L.zip rIds rcps) $ \rcp ->
         ExceptT $ atomically $ addRecipient st sId rcp
     noFile $ either FRErr (const $ FRSndIds sId rIds) r
-  XFTPReqCmd fr (FileCmd _ cmd) -> case cmd of
+  XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
     FADD _rcps -> noFile FROk
     FPUT -> (,Nothing) <$> receiveServerFile fr
-    FDEL -> noFile FROk
+    FDEL -> (,Nothing) <$> deleteServerFile fr
     FGET rDhKey -> sendServerFile fr rDhKey
-    FACK -> noFile FROk
+    FACK -> (,Nothing) <$> ackFileReception fId fr
     -- it should never get to the options below, they are passed in other constructors of XFTPRequest
     FNEW _ _ -> noFile $ FRErr INTERNAL
     PING -> noFile FRPong
@@ -217,7 +218,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         liftIO $
           runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
             Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk
-            Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
+            Left e -> (whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError) $> FRErr e
 
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rDhKey = do
@@ -231,6 +232,25 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
             _ -> (FRErr INTERNAL, Nothing)
         _ -> pure (FRErr NO_FILE, Nothing)
 
+    deleteServerFile :: FileRec -> M FileResponse
+    deleteServerFile FileRec {senderId, filePath} = do
+      r <- runExceptT $ do
+        path <- readTVarIO filePath
+        ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p))
+        st <- asks store
+        void $ atomically $ deleteFile st senderId
+        pure FROk
+      either (pure . FRErr) pure r
+
+    logFileError :: SomeException -> IO ()
+    logFileError e = logError $ "Error deleting file: " <> tshow e
+
+    ackFileReception :: RecipientId -> FileRec -> M FileResponse
+    ackFileReception rId fr = do
+      st <- asks store
+      atomically $ deleteRecipient st rId fr
+      pure FROk
+
 randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs
index 6a7edd36f..9147f1f20 100644
--- a/src/Simplex/FileTransfer/Server/Env.hs
+++ b/src/Simplex/FileTransfer/Server/Env.hs
@@ -14,7 +14,7 @@ import Data.Time.Clock (getCurrentTime)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.FileTransfer.Protocol (FileCmd, FileInfo)
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo, XFTPFileId)
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
@@ -63,5 +63,5 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, caCertificateFile, certi
 
 data XFTPRequest
   = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey)
-  | XFTPReqCmd FileRec FileCmd
+  | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index 9ea6f0496..01d6f9a80 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -11,6 +11,7 @@ module Simplex.FileTransfer.Server.Store
     setFilePath,
     addRecipient,
     deleteFile,
+    deleteRecipient,
     getFile,
     ackFile,
   )
@@ -84,6 +85,11 @@ deleteFile FileStore {files, recipients} senderId = do
       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
   SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 429973c7b..0c5d1ecb0 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -1,17 +1,19 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 
 module XFTPServerTests where
 
 import AgentTests.FunctionalAPITests (runRight_)
+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 Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
@@ -30,8 +32,12 @@ xftpServerTests =
     . after_ (removeDirectoryRecursive xftpServerFiles)
     $ do
       describe "XFTP file chunk delivery" $ do
-        it "should create, upload and receive file chunk" testFileChunkDelivery
+        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
 
 chSize :: Num n => n
 chSize = 128 * 1024
@@ -72,3 +78,56 @@ runTestFileChunkDelivery s r = do
     `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.sha512Hash <$> 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]
+  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.sha512Hash <$> 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]
+  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))

From 1f394b76a61300cf2159cb55df64ab6232522894 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Wed, 22 Feb 2023 17:16:49 +0400
Subject: [PATCH 22/71] xftp: sender file description (#647)

* xftp: sender file description

* tests

* check, info, tests

* test

* refactor

* refactor, rename sender file

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Client/Main.hs | 119 ++++++++++++++++--------
 src/Simplex/FileTransfer/Description.hs |  95 ++++++++++++-------
 src/Simplex/FileTransfer/Protocol.hs    |  66 ++++++++-----
 src/Simplex/Messaging/Protocol.hs       |   6 +-
 tests/FileDescriptionTests.hs           |  29 +++---
 tests/XFTPCLI.hs                        |  45 ++++++---
 tests/fixtures/file_description.yaml    |   1 +
 7 files changed, 234 insertions(+), 127 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 4e74a5659..20e5bd7f9 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -1,5 +1,7 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -28,7 +30,7 @@ import Options.Applicative
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Client.Agent
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileInfo (..))
+import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -175,8 +177,8 @@ data SentRecipientReplica = SentRecipientReplica
   { chunkNo :: Int,
     server :: XFTPServer,
     rcvNo :: Int,
-    rcvId :: ChunkReplicaId,
-    rcvKey :: C.APrivateSignKey,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
     digest :: FileDigest,
     chunkSize :: FileSize Word32
   }
@@ -213,16 +215,20 @@ instance Encoding FileHeader where
 cliSendFile :: SendOptions -> ExceptT CLIError IO ()
 cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
   let (_, fileName) = splitFileName filePath
-  (encPath, fd, chunkSpecs) <- encryptFile fileName
+  (encPath, fdRcv, fdSnd, chunkSpecs) <- encryptFile fileName
   sentChunks <- uploadFile chunkSpecs
   whenM (doesFileExist encPath) $ removeFile encPath
   -- TODO if only small chunks, use different default size
   liftIO $ do
-    fds <- writeFileDescriptions fileName $ createFileDescriptions fd sentChunks
+    let fdRcvs = createRcvFileDescriptions fdRcv sentChunks
+        fdSnd' = createSndFileDescription fdSnd sentChunks
+    (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd'
     putStrLn "File uploaded!\nPass file descriptions to the recipient(s):"
-    forM_ fds putStrLn
+    forM_ fdRcvPaths putStrLn
+    putStrLn "Sender file description:"
+    putStrLn fdSndPath
   where
-    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription, [XFTPChunkSpec])
+    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec])
     encryptFile fileName = do
       encPath <- getEncPath tempPath "xftp"
       key <- liftIO C.randomSbKey
@@ -235,8 +241,9 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
-          fd = FileDescription {size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
-      pure (encPath, fd, chunkSpecs)
+          fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
+          fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
+      pure (encPath, fdRcv, fdSnd, chunkSpecs)
       where
         encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
         encrypt fileHdr key nonce fileSize' encSize encFile = do
@@ -285,8 +292,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
     -- M chunks, R replicas, N recipients
     -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
     -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
-    createFileDescriptions :: FileDescription -> [SentFileChunk] -> [FileDescription]
-    createFileDescriptions fd sentChunks = map (\chunks -> (fd :: FileDescription) {chunks}) rcvChunks
+    createRcvFileDescriptions :: FileDescription 'FPRecipient -> [SentFileChunk] -> [FileDescription 'FPRecipient]
+    createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FPRecipient)) {chunks}) rcvChunks
       where
         rcvReplicas :: [SentRecipientReplica]
         rcvReplicas =
@@ -294,7 +301,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
             ( \SentFileChunk {chunkNo, digest, chunkSize, replicas} ->
                 concatMap
                   ( \SentFileChunkReplica {server, recipients} ->
-                      zipWith (\rcvNo (rcvId, rcvKey) -> SentRecipientReplica {chunkNo, server, rcvNo, rcvId, rcvKey, digest, chunkSize}) [1 ..] recipients
+                      zipWith (\rcvNo (replicaId, replicaKey) -> SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize}) [1 ..] recipients
                   )
                   replicas
             )
@@ -305,7 +312,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         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, rcvId, rcvKey, digest, chunkSize} =
+        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
@@ -316,38 +323,58 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
             addOrChangeChunk = \case
               Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas}
               _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
-            replica = FileChunkReplica {server, rcvId, rcvKey}
-    writeFileDescriptions :: String -> [FileDescription] -> IO [FilePath]
-    writeFileDescriptions fileName fds = do
+            replica = FileChunkReplica {server, replicaId, replicaKey}
+    createSndFileDescription :: FileDescription 'FPSender -> [SentFileChunk] -> FileDescription 'FPSender
+    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 'FPRecipient] -> FileDescription 'FPSender -> IO ([FilePath], FilePath)
+    writeFileDescriptions fileName fdRcvs fdSnd = do
       outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
       createDirectoryIfMissing True outDir
-      forM (zip [1 ..] fds) $ \(i :: Int, fd) -> do
+      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} = do
-  ValidFileDescription FileDescription {size, digest, key, nonce, chunks} <- getFileDescription fileDescription
-  encPath <- getEncPath tempPath "xftp"
-  createDirectory encPath
-  a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
-  chunkPaths <- forM chunks $ downloadFileChunk a encPath
-  encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
-  when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
-  path <- decryptFile chunkPaths key nonce
-  whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
-  liftIO $ putStrLn $ "File received: " <> path
+cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} =
+  getFileDescription' fileDescription >>= receiveFile
   where
+    receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
+    receiveFile (ValidFileDescription FileDescription {digest, key, nonce, chunks}) = do
+      encPath <- getEncPath tempPath "xftp"
+      createDirectory encPath
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      chunkPaths <- forM chunks $ downloadFileChunk a encPath
+      encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
+      when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
+      path <- decryptFile chunkPaths key nonce
+      whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
+      liftIO $ putStrLn $ "File received: " <> path
     retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
     retries = withRetry retryCount . withExceptT (CLIError . show)
     downloadFileChunk :: XFTPClientAgent -> FilePath -> FileChunk -> ExceptT CLIError IO FilePath
     downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
-      let FileChunkReplica {server, rcvId, rcvKey} = replica
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
       chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- retries $ getXFTPServerClient a server
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) chunkSpec
+      retries $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
@@ -376,24 +403,36 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
 
 cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
 cliFileDescrInfo InfoOptions {fileDescription} = do
-  ValidFileDescription FileDescription {size, chunkSize, chunks} <- getFileDescription fileDescription
-  let replicas = groupReplicasByServer chunkSize chunks
-  liftIO $ do
-    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)
+  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
+          SRecipient -> putStrLn "Recipient file description"
+          SSender -> putStrLn "Sender file description"
 
 strEnc :: StrEncoding a => a -> String
 strEnc = B.unpack . strEncode
 
-getFileDescription :: FilePath -> ExceptT CLIError IO ValidFileDescription
+getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription
 getFileDescription path = do
   fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
   liftEither . first CLIError $ validateFileDescription fd
 
+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 0 = []
 prepareChunkSizes size
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index c4cdc5d6e..289d716c3 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -2,15 +2,21 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
-    ValidFileDescription,
+    AFileDescription (..),
+    ValidFileDescription, -- constructor is not exported, use pattern
     pattern ValidFileDescription,
+    AValidFileDescription (..),
     FileDigest (..),
     FileChunk (..),
     FileChunkReplica (..),
@@ -43,14 +49,16 @@ import Data.Maybe (fromMaybe)
 import Data.Word (Word32)
 import qualified Data.Yaml as Y
 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 = FileDescription
-  { size :: FileSize Int64,
+data FileDescription (p :: FileParty) = FileDescription
+  { party :: SFileParty p,
+    size :: FileSize Int64,
     digest :: FileDigest,
     key :: C.SbKey,
     nonce :: C.CbNonce,
@@ -59,11 +67,17 @@ data FileDescription = FileDescription
   }
   deriving (Eq, Show)
 
-newtype ValidFileDescription = ValidFD FileDescription
+data AFileDescription = forall p. FilePartyI p => AFD (FileDescription p)
 
-pattern ValidFileDescription :: FileDescription -> ValidFileDescription
+newtype ValidFileDescription p = ValidFD (FileDescription p)
+
+pattern ValidFileDescription :: FileDescription p -> ValidFileDescription p
 pattern ValidFileDescription fd = ValidFD fd
 
+{-# COMPLETE ValidFileDescription #-}
+
+data AValidFileDescription = forall p. FilePartyI p => AVFD (ValidFileDescription p)
+
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
 
@@ -89,8 +103,8 @@ data FileChunk = FileChunk
 
 data FileChunkReplica = FileChunkReplica
   { server :: XFTPServer,
-    rcvId :: ChunkReplicaId,
-    rcvKey :: C.APrivateSignKey
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey
   }
   deriving (Eq, Show)
 
@@ -109,7 +123,8 @@ instance ToJSON ChunkReplicaId where
   toEncoding = strToJEncoding
 
 data YAMLFileDescription = YAMLFileDescription
-  { size :: String,
+  { party :: FileParty,
+    size :: String,
     digest :: FileDigest,
     key :: C.SbKey,
     nonce :: C.CbNonce,
@@ -135,31 +150,38 @@ instance ToJSON YAMLServerReplicas where
 data FileServerReplica = FileServerReplica
   { chunkNo :: Int,
     server :: XFTPServer,
-    rcvId :: ChunkReplicaId,
-    rcvKey :: C.APrivateSignKey,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
     digest :: Maybe FileDigest,
     chunkSize :: Maybe (FileSize Word32)
   }
   deriving (Show)
 
-instance StrEncoding FileDescription where
+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 :: FileDescription -> Either String ValidFileDescription
-validateFileDescription fd@FileDescription {size, chunks}
-  | chunkNos /= [1 .. length chunks] = Left "chunk numbers are not sequential"
-  | chunksSize chunks /= unFileSize size = Left "chunks total size is different than file size"
-  | otherwise = Right $ ValidFD fd
-  where
-    chunkNos = map (chunkNo :: FileChunk -> Int) chunks
-    chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
+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 -> YAMLFileDescription
-encodeFileDescription FileDescription {size, digest, key, nonce, chunkSize, chunks} =
+encodeFileDescription :: FileDescription p -> YAMLFileDescription
+encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks} =
   YAMLFileDescription
-    { size = B.unpack $ strEncode size,
+    { party = toFileParty party,
+      size = B.unpack $ strEncode size,
       digest,
       key,
       nonce,
@@ -209,41 +231,42 @@ replicaServer :: FileServerReplica -> XFTPServer
 replicaServer = server
 
 encodeServerReplica :: FileServerReplica -> ByteString
-encodeServerReplica FileServerReplica {chunkNo, rcvId, rcvKey, digest, chunkSize} =
+encodeServerReplica FileServerReplica {chunkNo, replicaId, replicaKey, digest, chunkSize} =
   bshow chunkNo
     <> ":"
-    <> strEncode rcvId
+    <> strEncode replicaId
     <> ":"
-    <> strEncode rcvKey
+    <> strEncode replicaKey
     <> maybe "" ((":" <>) . strEncode) digest
     <> maybe "" ((":" <>) . strEncode) chunkSize
 
 serverReplicaP :: XFTPServer -> Parser FileServerReplica
 serverReplicaP server = do
   chunkNo <- A.decimal
-  rcvId <- A.char ':' *> strP
-  rcvKey <- A.char ':' *> strP
+  replicaId <- A.char ':' *> strP
+  replicaKey <- A.char ':' *> strP
   digest <- optional (A.char ':' *> strP)
   chunkSize <- optional (A.char ':' *> strP)
-  pure FileServerReplica {chunkNo, server, rcvId, rcvKey, digest, chunkSize}
+  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, rcvId, rcvKey} =
+    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, rcvId, rcvKey, digest = digest', chunkSize = chunkSize'}
+       in FileServerReplica {chunkNo, server, replicaId, replicaKey, digest = digest', chunkSize = chunkSize'}
 
-decodeFileDescription :: YAMLFileDescription -> Either String FileDescription
-decodeFileDescription YAMLFileDescription {size, digest, key, nonce, chunkSize, replicas} = do
+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 FileDescription {size = size', digest, key, nonce, chunkSize = chunkSize', chunks}
+  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
 
@@ -275,15 +298,15 @@ foldReplicasToChunks defChunkSize fs = do
     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, rcvId, rcvKey} = do
+    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, rcvId, rcvKey}
+          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, rcvId, rcvKey}
+              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
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 56fd9be32..bc1cdb17b 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -13,6 +13,8 @@
 
 module Simplex.FileTransfer.Protocol where
 
+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)
@@ -27,6 +29,7 @@ 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
   ( CommandError (..),
     Protocol (..),
@@ -61,34 +64,55 @@ xftpBlockSize :: Int
 xftpBlockSize = 16384
 
 -- | File protocol clients
-data FileParty = Recipient | Sender
-  deriving (Show)
+data FileParty = FPRecipient | FPSender
+  deriving (Eq, Show, Generic)
+
+instance FromJSON FileParty where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "FP"
+
+instance ToJSON FileParty where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "FP"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "FP"
 
 data SFileParty :: FileParty -> Type where
-  SRecipient :: SFileParty Recipient
-  SSender :: SFileParty Sender
+  SRecipient :: SFileParty FPRecipient
+  SSender :: SFileParty FPSender
 
 instance TestEquality SFileParty where
   testEquality SRecipient SRecipient = Just Refl
   testEquality SSender SSender = 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
+  SRecipient -> FPRecipient
+  SSender -> FPSender
+
+aFileParty :: FileParty -> AFileParty
+aFileParty = \case
+  FPRecipient -> AFP SRecipient
+  FPSender -> AFP SSender
+
 class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p
 
-instance FilePartyI Recipient where sFileParty = SRecipient
+instance FilePartyI FPRecipient where sFileParty = SRecipient
 
-instance FilePartyI Sender where sFileParty = SSender
+instance FilePartyI FPSender where sFileParty = SSender
 
 data FileCommandTag (p :: FileParty) where
-  FNEW_ :: FileCommandTag Sender
-  FADD_ :: FileCommandTag Sender
-  FPUT_ :: FileCommandTag Sender
-  FDEL_ :: FileCommandTag Sender
-  FGET_ :: FileCommandTag Recipient
-  FACK_ :: FileCommandTag Recipient
-  PING_ :: FileCommandTag Recipient
+  FNEW_ :: FileCommandTag FPSender
+  FADD_ :: FileCommandTag FPSender
+  FPUT_ :: FileCommandTag FPSender
+  FDEL_ :: FileCommandTag FPSender
+  FGET_ :: FileCommandTag FPRecipient
+  FACK_ :: FileCommandTag FPRecipient
+  PING_ :: FileCommandTag FPRecipient
 
 deriving instance Show (FileCommandTag p)
 
@@ -133,13 +157,13 @@ instance Protocol XFTPErrorType FileResponse where
     _ -> Nothing
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand Sender
-  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
-  FPUT :: FileCommand Sender
-  FDEL :: FileCommand Sender
-  FGET :: RcvPublicDhKey -> FileCommand Recipient
-  FACK :: FileCommand Recipient
-  PING :: FileCommand Recipient
+  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
+  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
+  FPUT :: FileCommand FPSender
+  FDEL :: FileCommand FPSender
+  FGET :: RcvPublicDhKey -> FileCommand FPRecipient
+  FACK :: FileCommand FPRecipient
+  PING :: FileCommand FPRecipient
 
 deriving instance Show (FileCommand p)
 
@@ -357,7 +381,7 @@ instance Encoding XFTPErrorType where
 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 "bad command party"
+  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
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 4bba022ad..998c1c66a 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -167,7 +167,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 (..))
 
@@ -1153,9 +1153,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
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
index b8fa62da9..f8425ce44 100644
--- a/tests/FileDescriptionTests.hs
+++ b/tests/FileDescriptionTests.hs
@@ -10,6 +10,7 @@ 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)
@@ -38,10 +39,11 @@ testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTF
 testCbNonce :: C.CbNonce
 testCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
 
-fileDesc :: FileDescription
+fileDesc :: FileDescription 'FPRecipient
 fileDesc =
   FileDescription
-    { size = FileSize $ 26 * mb,
+    { party = SRecipient,
+      size = FileSize $ 26 * mb,
       digest = FileDigest "abc",
       key = testSbKey,
       nonce = testCbNonce,
@@ -52,8 +54,8 @@ fileDesc =
               digest = chunkDigest,
               chunkSize = defaultChunkSize,
               replicas =
-                [ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
-                  FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
+                [ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
                 ]
             },
           FileChunk
@@ -61,8 +63,8 @@ fileDesc =
               digest = chunkDigest,
               chunkSize = defaultChunkSize,
               replicas =
-                [ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
-                  FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
+                [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey}
                 ]
             },
           FileChunk
@@ -70,8 +72,8 @@ fileDesc =
               digest = chunkDigest,
               chunkSize = defaultChunkSize,
               replicas =
-                [ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
-                  FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
+                [ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey}
                 ]
             },
           FileChunk
@@ -79,22 +81,23 @@ fileDesc =
               digest = chunkDigest,
               chunkSize = FileSize $ 2 * mb,
               replicas =
-                [ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
-                  FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
+                [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
+                  FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
                 ]
             }
         ]
     }
   where
     defaultChunkSize = FileSize $ 8 * mb
-    rcvId = ChunkReplicaId "abc"
-    rcvKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+    replicaId = ChunkReplicaId "abc"
+    replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
     chunkDigest = FileDigest "ghi"
 
 yamlFileDesc :: YAMLFileDescription
 yamlFileDesc =
   YAMLFileDescription
-    { size = "26mb",
+    { party = FPRecipient,
+      size = "26mb",
       chunkSize = "8mb",
       digest = FileDigest "abc",
       key = testSbKey,
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 5897c4b0b..0a53aa9cd 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -39,17 +39,28 @@ testXFTPCLISendReceive = withXFTPServer $ do
   xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
   getFileSize filePath `shouldReturn` 19 * mb
-  let fd1 = filePath <> ".xftp" </> "rcv1.xftp"
-      fd2 = filePath <> ".xftp" </> "rcv2.xftp"
+  let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
   xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
-    `shouldReturn` ["File uploaded!", "Pass file descriptions to the recipient(s):", fd1, fd2]
-  testReceiveFile fd1 "testfile" file
-  testReceiveFile fd2 "testfile_1" file
+    `shouldReturn` [ "File uploaded!",
+                     "Pass file descriptions to the recipient(s):",
+                     fdRcv1,
+                     fdRcv2,
+                     "Sender file description:",
+                     fdSnd
+                   ]
+  testInfoFile fdRcv1 "Recipient"
+  testReceiveFile fdRcv1 "testfile" file
+  testInfoFile fdRcv2 "Recipient"
+  testReceiveFile fdRcv2 "testfile_1" file
+  testInfoFile fdSnd "Sender"
   where
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
-    testReceiveFile fd fileName file = do
+    testInfoFile fd party = do
       xftp ["info", fd]
-        `shouldReturn` ["File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
+        `shouldReturn` [party <> " file description", "File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
+    testReceiveFile fd fileName file = do
       xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
         `shouldReturn` ["File received: " <> recipientFiles </> fileName]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
@@ -60,16 +71,24 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
   getFileSize filePath `shouldReturn` 19 * mb
-  let fd1 = filePath <> ".xftp" </> "rcv1.xftp"
-      fd2 = filePath <> ".xftp" </> "rcv2.xftp"
+  let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
   xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
-    `shouldReturn` ["File uploaded!", "Pass file descriptions to the recipient(s):", fd1, fd2]
-  testReceiveFile fd1 "testfile" file
-  testReceiveFile fd2 "testfile_1" file
+    `shouldReturn` [ "File uploaded!",
+                     "Pass file descriptions to the recipient(s):",
+                     fdRcv1,
+                     fdRcv2,
+                     "Sender file description:",
+                     fdSnd
+                   ]
+  testReceiveFile fdRcv1 "testfile" file
+  testReceiveFile fdRcv2 "testfile_1" file
   where
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testReceiveFile fd fileName file = do
-      sizeStr : srvStr : srvs <- xftp ["info", fd]
+      partyStr : sizeStr : srvStr : srvs <- xftp ["info", fd]
+      partyStr `shouldContain` "Recipient file description"
       sizeStr `shouldBe` "File download size: 20mb"
       srvStr `shouldBe` "File server(s):"
       case srvs of
diff --git a/tests/fixtures/file_description.yaml b/tests/fixtures/file_description.yaml
index a96e9a4f3..6ba8a0a6e 100644
--- a/tests/fixtures/file_description.yaml
+++ b/tests/fixtures/file_description.yaml
@@ -2,6 +2,7 @@ chunkSize: 8mb
 digest: YWJj
 key: 00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=
 nonce: dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu
+party: recipient
 replicas:
 - chunks:
   - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp

From fbf0b8b1751139161bb5ac4d4315773d66ac1ce8 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 23 Feb 2023 16:54:50 +0400
Subject: [PATCH 23/71] xftp: cli - delete file command, acknowledge received
 chunks (#649)

---
 src/Simplex/FileTransfer/Client/Main.hs | 69 +++++++++++++++++++------
 tests/XFTPCLI.hs                        | 45 ++++++++++++++--
 2 files changed, 94 insertions(+), 20 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 20e5bd7f9..622767fd2 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -71,6 +71,7 @@ newtype CLIError = CLIError String
 data CliCommand
   = SendFile SendOptions
   | ReceiveFile ReceiveOptions
+  | DeleteFile DeleteOptions
   | RandomFile RandomFileOptions
   | FileDescrInfo InfoOptions
 
@@ -92,6 +93,12 @@ data ReceiveOptions = ReceiveOptions
   }
   deriving (Show)
 
+data DeleteOptions = DeleteOptions
+  { fileDescription :: FilePath,
+    retryCount :: Int
+  }
+  deriving (Show)
+
 newtype InfoOptions = InfoOptions
   { fileDescription :: FilePath
   }
@@ -114,6 +121,7 @@ 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"))
         <> command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size"))
     )
@@ -125,15 +133,20 @@ cliCommandP =
         <*> 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
-        <*> retries
+        <*> retryCountP
         <*> temp
     receiveP :: Parser ReceiveOptions
     receiveP =
       ReceiveOptions
         <$> fileDescrArg
         <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
-        <*> retries
+        <*> retryCountP
         <*> temp
+    deleteP :: Parser DeleteOptions
+    deleteP =
+      DeleteOptions
+        <$> fileDescrArg
+        <*> retryCountP
     infoP :: Parser InfoOptions
     infoP = InfoOptions <$> fileDescrArg
     randomP :: Parser RandomFileOptions
@@ -143,7 +156,7 @@ cliCommandP =
         <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb)")
     strDec = eitherReader $ strDecode . B.pack
     fileDescrArg = argument str (metavar "FILE" <> help "File description file")
-    retries = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault)
+    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)")
     xftpServers =
       option
@@ -188,6 +201,7 @@ xftpClientCLI =
   getCliCommand' cliCommandP clientVersion >>= \case
     SendFile opts -> runE $ cliSendFile opts
     ReceiveFile opts -> runE $ cliReceiveFile opts
+    DeleteFile opts -> runE $ cliDeleteFile opts
     FileDescrInfo opts -> runE $ cliFileDescrInfo opts
     RandomFile opts -> cliRandomFile opts
   where
@@ -263,17 +277,15 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       -- TODO unshuffle chunks
       pure $ map snd sentChunks
       where
-        retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
-        retries = withRetry retryCount . withExceptT (CLIError . show)
         uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
           (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
           rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
           chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
           xftpServer <- liftIO $ getXFTPServer gen srvs
-          c <- retries $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- retries $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
-          retries $ uploadXFTPChunk c spKey sndId chunkSpec
+          c <- withRetry retryCount $ getXFTPServerClient a xftpServer
+          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
+          withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
           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})
@@ -364,17 +376,17 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
       when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
       path <- decryptFile chunkPaths key nonce
+      forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
       liftIO $ putStrLn $ "File received: " <> path
-    retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
-    retries = withRetry retryCount . withExceptT (CLIError . show)
+      liftIO $ putStrLn "File description cannot be used again"
     downloadFileChunk :: XFTPClientAgent -> FilePath -> FileChunk -> ExceptT CLIError IO FilePath
     downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
       chunkPath <- uniqueCombine encPath $ show chunkNo
-      c <- retries $ getXFTPServerClient a server
+      c <- withRetry retryCount $ getXFTPServerClient a server
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      retries $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
@@ -400,6 +412,28 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
           ifM (doesDirectoryExist path) (uniqueCombine path name) $
             ifM (doesFileExist path) (throwError $ CLIError "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"
+
+cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
+cliDeleteFile DeleteOptions {fileDescription, retryCount} = do
+  getFileDescription' fileDescription >>= deleteFile
+  where
+    deleteFile :: ValidFileDescription 'FPSender -> ExceptT CLIError IO ()
+    deleteFile (ValidFileDescription FileDescription {chunks}) = do
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      forM_ chunks $ deleteFileChunk a
+      liftIO $ putStrLn "File deleted"
+    deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
+    deleteFileChunk a FileChunk {replicas = replica : _} = do
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
+      c <- withRetry retryCount $ getXFTPServerClient a server
+      withRetry retryCount $ deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+    deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
 
 cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
 cliFileDescrInfo InfoOptions {fileDescription} = do
@@ -464,10 +498,13 @@ uniqueCombine filePath fileName = tryCombine (0 :: Int)
           f = filePath </> (name <> suffix <> ext)
        in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f)
 
-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` \_ -> withRetry (n - 1) a
+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` \_ -> withRetry' (n - 1) a
 
 cliRandomFile :: RandomFileOptions -> IO ()
 cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 0a53aa9cd..d93660baf 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -4,7 +4,7 @@ import Control.Exception (bracket_)
 import qualified Data.ByteString as LB
 import Data.List (isInfixOf)
 import Simplex.FileTransfer.Client.Main (xftpClientCLI)
-import System.Directory (createDirectoryIfMissing, getFileSize, removeDirectoryRecursive)
+import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive)
 import System.Environment (withArgs)
 import System.FilePath ((</>))
 import System.IO.Silently (capture_)
@@ -15,6 +15,7 @@ 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
 
 testBracket :: IO () -> IO ()
 testBracket =
@@ -55,6 +56,8 @@ testXFTPCLISendReceive = withXFTPServer $ do
   testInfoFile fdRcv2 "Recipient"
   testReceiveFile fdRcv2 "testfile_1" file
   testInfoFile fdSnd "Sender"
+  xftp ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
+    `shouldThrow` anyException
   where
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testInfoFile fd party = do
@@ -62,7 +65,7 @@ testXFTPCLISendReceive = withXFTPServer $ do
         `shouldReturn` [party <> " file description", "File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
     testReceiveFile fd fileName file = do
       xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
-        `shouldReturn` ["File received: " <> recipientFiles </> fileName]
+        `shouldReturn` ["File received: " <> recipientFiles </> fileName, "File description cannot be used again"]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLISendReceive2servers :: IO ()
@@ -98,5 +101,39 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
           srv2 `shouldContain` testXFTPServerStr2
         _ -> print srvs >> error "more than 2 servers returned"
       xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
-        `shouldReturn` ["File received: " <> recipientFiles </> fileName]
-      LB.readFile (recipientFiles </> fileName) `shouldReturn` file
\ No newline at end of file
+        `shouldReturn` ["File received: " <> recipientFiles </> fileName, "File description cannot be used again"]
+      LB.readFile (recipientFiles </> fileName) `shouldReturn` file
+
+testXFTPCLIDelete :: IO ()
+testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
+  let filePath = senderFiles </> "testfile"
+  xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` 19 * mb
+  let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
+      fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
+      fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
+  xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+    `shouldReturn` [ "File uploaded!",
+                     "Pass file descriptions to the recipient(s):",
+                     fdRcv1,
+                     fdRcv2,
+                     "Sender file description:",
+                     fdSnd
+                   ]
+  xftp ["del", fdRcv1]
+    `shouldThrow` anyException
+  xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp"]
+    `shouldReturn` ["File received: " <> recipientFiles </> "testfile", "File description cannot be used again"]
+  LB.readFile (recipientFiles </> "testfile") `shouldReturn` file
+  fs1 <- listDirectory xftpServerFiles
+  fs2 <- listDirectory xftpServerFiles2
+  length fs1 + length fs2 `shouldBe` 6
+  xftp ["del", fdSnd]
+    `shouldReturn` ["File deleted"]
+  listDirectory xftpServerFiles >>= (`shouldBe` [])
+  listDirectory xftpServerFiles2 >>= (`shouldBe` [])
+  xftp ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
+    `shouldThrow` anyException
+  where
+    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)

From 4ce4fa3423572bc1bee54b98748cfb5f4b302035 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 23 Feb 2023 18:28:20 +0000
Subject: [PATCH 24/71] xftp: write secret_box auth tag to the end of the file,
 for efficiency of ecryption/decryption (#650)

* xftp: write secret_box auth tag to the end of the file, for efficiency of ecryption/decryption

* comments
---
 src/Simplex/FileTransfer/Client.hs      |  2 +-
 src/Simplex/FileTransfer/Client/Main.hs | 29 +++++++++++---------
 src/Simplex/FileTransfer/Description.hs |  8 ++++--
 src/Simplex/FileTransfer/Protocol.hs    |  4 +++
 src/Simplex/FileTransfer/Transport.hs   |  2 +-
 src/Simplex/Messaging/Crypto.hs         |  4 ---
 src/Simplex/Messaging/Crypto/Lazy.hs    | 35 +++++++++++++++++++++++++
 tests/CoreTests/CryptoTests.hs          | 29 ++++++++++++++++++++
 tests/XFTPServerTests.hs                | 24 +++++++++--------
 9 files changed, 105 insertions(+), 32 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 5c9a475cf..27e0cdd70 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -120,7 +120,7 @@ sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fI
       forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
         withFile filePath ReadMode $ \h -> do
           hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-          sendFile h send chunkSize
+          sendFile h send $ fromIntegral chunkSize
       done
 
 createXFTPChunk ::
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 622767fd2..63939c296 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -59,8 +59,8 @@ smallChunkSize = 1 * mb
 fileSizeLen :: Int64
 fileSizeLen = 8
 
-cbAuthTagLen :: Int64
-cbAuthTagLen = fromIntegral C.cbAuthTagSize
+authTagSize :: Int64
+authTagSize = fromIntegral C.authTagSize
 
 mb :: Num a => a
 mb = 1024 * 1024
@@ -153,7 +153,7 @@ cliCommandP =
     randomP =
       RandomFileOptions
         <$> argument str (metavar "FILE" <> help "Path to save file")
-        <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb)")
+        <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb/gb)")
     strDec = eitherReader $ strDecode . B.pack
     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)
@@ -250,8 +250,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       fileSize <- fromInteger <$> getFileSize filePath
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
-          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + cbAuthTagLen
-          encSize = fromIntegral $ sum chunkSizes
+          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
+          encSize = sum $ map fromIntegral chunkSizes
       encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
@@ -263,10 +263,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         encrypt fileHdr key nonce fileSize' encSize encFile = do
           f <- liftIO $ LB.readFile filePath
           let f' = LB.fromStrict fileHdr <> f
-          c <- liftEither $ first (CLIError . show) $ LC.sbEncrypt key nonce f' fileSize' $ encSize - cbAuthTagLen
+          c <- liftEither $ first (CLIError . show) $ LC.sbEncryptTailTag key nonce f' fileSize' $ encSize - authTagSize
           liftIO $ LB.writeFile encFile c
-    -- let padSize = paddedSize - fileSize - fromIntegral (B.length fileHdr)
-    -- when (padSize > 0) . LB.hPut h $ LB.replicate padSize '#'
     uploadFile :: [XFTPChunkSpec] -> ExceptT CLIError IO [SentFileChunk]
     uploadFile chunks = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
@@ -368,14 +366,16 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
   getFileDescription' fileDescription >>= receiveFile
   where
     receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
-    receiveFile (ValidFileDescription FileDescription {digest, key, nonce, chunks}) = do
+    receiveFile (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do
       encPath <- getEncPath tempPath "xftp"
       createDirectory encPath
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       chunkPaths <- forM chunks $ downloadFileChunk a encPath
       encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
       when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
-      path <- decryptFile chunkPaths key nonce
+      encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
+      path <- decryptFile encSize chunkPaths key nonce
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
       liftIO $ putStrLn $ "File received: " <> path
@@ -389,9 +389,9 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
       pure chunkPath
     downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
-    decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
-    decryptFile chunkPaths key nonce = do
-      f <- liftEither . first (CLIError . show) . LC.sbDecrypt key nonce =<< liftIO (readChunks chunkPaths)
+    decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
+    decryptFile encSize chunkPaths key nonce = do
+      (authOk, f) <- liftEither . first (CLIError . show) . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
       let (fileHdr, f') = LB.splitAt 1024 f
       -- withFile encPath ReadMode $ \r -> do
       --   fileHdr <- liftIO $ B.hGet r 1024
@@ -401,6 +401,9 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
         A.Done rest FileHeader {fileName} -> do
           path <- getFilePath fileName
           liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
+          unless authOk $ do
+            removeFile path
+            throwError $ CLIError "Error decrypting file: incorrect auth tag"
           pure path
     readChunks :: [FilePath] -> IO LB.ByteString
     readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) LB.empty
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 289d716c3..7b3eee7e9 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -196,20 +196,24 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
   strEncode (FileSize b)
     | b' /= 0 = bshow b
     | kb' /= 0 = bshow kb <> "kb"
-    | otherwise = bshow mb <> "mb"
+    | mb' /= 0 = bshow mb <> "mb"
+    | otherwise = bshow gb <> "gb"
     where
       (kb, b') = b `divMod` 1024
       (mb, kb') = kb `divMod` 1024
+      (gb, mb') = mb `divMod` 1024
   strP =
     FileSize
       <$> A.choice
-        [ (mb *) <$> A.decimal <* "mb",
+        [ (gb *) <$> A.decimal <* "gb",
+          (mb *) <$> A.decimal <* "mb",
           (kb *) <$> A.decimal <* "kb",
           A.decimal
         ]
     where
       kb = 1024
       mb = 1024 * kb
+      gb = 1024 * mb
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index bc1cdb17b..41d7b7aff 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -337,6 +337,8 @@ data XFTPErrorType
     SIZE
   | -- | 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
@@ -357,6 +359,7 @@ instance Encoding XFTPErrorType where
     AUTH -> "AUTH"
     SIZE -> "SIZE"
     DIGEST -> "DIGEST"
+    CRYPTO -> "CRYPTO"
     NO_FILE -> "NO_FILE"
     HAS_FILE -> "HAS_FILE"
     FILE_IO -> "FILE_IO"
@@ -371,6 +374,7 @@ instance Encoding XFTPErrorType where
       "AUTH" -> pure AUTH
       "SIZE" -> pure SIZE
       "DIGEST" -> pure DIGEST
+      "CRYPTO" -> pure CRYPTO
       "NO_FILE" -> pure NO_FILE
       "HAS_FILE" -> pure HAS_FILE
       "FILE_IO" -> pure FILE_IO
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index a57848d62..ad94b551d 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -103,7 +103,7 @@ receiveEncFile getBody = receiveFile_ . receive
                     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 DIGEST
+                pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO
           | otherwise -> pure $ Left SIZE
     authSz = fromIntegral C.authTagSize
 
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 235b6919c..a6574c4af 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -121,7 +121,6 @@ module Simplex.Messaging.Crypto
     sbKey,
     unsafeSbKey,
     randomSbKey,
-    cbAuthTagSize,
 
     -- * pseudo-random bytes
     pseudoRandomBytes,
@@ -993,9 +992,6 @@ sbDecrypt_ secret (CbNonce nonce) packet
     (rs, msg) = xSalsa20 secret nonce c
     tag = Poly1305.auth rs c
 
-cbAuthTagSize :: Int
-cbAuthTagSize = 16
-
 newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
   deriving (Eq, Show)
 
diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs
index cb1d40aac..1e055bdfd 100644
--- a/src/Simplex/Messaging/Crypto/Lazy.hs
+++ b/src/Simplex/Messaging/Crypto/Lazy.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -11,9 +13,12 @@ module Simplex.Messaging.Crypto.Lazy
     unPad,
     sbEncrypt,
     sbDecrypt,
+    sbEncryptTailTag,
+    sbDecryptTailTag,
     fastReplicate,
     SbState,
     cbInit,
+    sbInit,
     sbEncryptChunk,
     sbDecryptChunk,
     sbAuth,
@@ -79,6 +84,7 @@ unPad padded
     (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) (CbNonce nonce) msg len paddedLen =
   prependTag <$> (secretBox sbEncryptChunk key nonce =<< pad msg len paddedLen)
@@ -86,6 +92,7 @@ sbEncrypt (SbKey key) (CbNonce nonce) msg len paddedLen =
     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) (CbNonce nonce) packet
   | LB.length tag' < 16 = Left CBDecryptError
@@ -104,12 +111,40 @@ secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
     update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
     run state = let (cs, state') = process state in BA.convert (sbAuth state') :| reverse cs
 
+-- | 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
+    (c, tag') = LB.splitAt paddedLen packet
+
+secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
+secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
+  where
+    process state = foldlChunks update ([], state) msg
+    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
+    run state = let (cs, state') = process state in reverse $ BA.convert (sbAuth state') : cs
+
 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
diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs
index 5033b4e4e..2f7b61f6b 100644
--- a/tests/CoreTests/CryptoTests.hs
+++ b/tests/CoreTests/CryptoTests.hs
@@ -76,6 +76,8 @@ cryptoTests = do
   describe "lazy secretbox" $ do
     testLazySecretBox
     testLazySecretBoxFile
+    testLazySecretBoxTailTag
+    testLazySecretBoxFileTailTag
   describe "X509 key encoding" $ do
     describe "Ed25519" $ testEncoding C.SEd25519
     describe "Ed448" $ testEncoding C.SEd448
@@ -148,6 +150,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
+
 testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec
 testEncoding alg = it "should encode / decode key" . ioProperty $ do
   (k, pk) <- C.generateKeyPair alg
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 0c5d1ecb0..695101a96 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module XFTPServerTests where
 
@@ -30,14 +31,14 @@ xftpServerTests :: Spec
 xftpServerTests =
   before_ (createDirectoryIfMissing False xftpServerFiles)
     . after_ (removeDirectoryRecursive xftpServerFiles)
+    . describe "XFTP file chunk delivery"
     $ do
-      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 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
 
 chSize :: Num n => n
 chSize = 128 * 1024
@@ -99,8 +100,9 @@ runTestFileChunkDelete s r = do
   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
+  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
@@ -113,7 +115,7 @@ testFileChunkAck2 :: Expectation
 testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
 
 runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
-runTestFileChunkAck s r =  do
+runTestFileChunkAck s r = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   bytes <- liftIO $ createTestChunk testChunkPath

From 3ab5e9d110407b312c8c056dfff7b3bc2a130efa Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 24 Feb 2023 07:09:51 +0000
Subject: [PATCH 25/71] xftp: expire files on the server, track/limit used
 storage (#651)

* xftp: expire files on the server

* track/limit used storage

* support storage quota and disabling queue creation in CLI parameters

* fix ini file

* correction

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Protocol.hs        |  4 ++
 src/Simplex/FileTransfer/Server.hs          | 45 +++++++++++++++--
 src/Simplex/FileTransfer/Server/Env.hs      | 29 ++++++++++-
 src/Simplex/FileTransfer/Server/Main.hs     | 40 ++++++++++++---
 src/Simplex/FileTransfer/Server/Store.hs    | 49 ++++++++++++------
 src/Simplex/FileTransfer/Server/StoreLog.hs | 19 +++----
 src/Simplex/Messaging/Server/CLI.hs         |  6 ++-
 src/Simplex/Messaging/Server/Main.hs        |  4 +-
 tests/XFTPClient.hs                         |  6 ++-
 tests/XFTPServerTests.hs                    | 55 +++++++++++++++++++++
 10 files changed, 214 insertions(+), 43 deletions(-)

diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 41d7b7aff..21e5e1cbe 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -335,6 +335,8 @@ data XFTPErrorType
     AUTH
   | -- | incorrent file size
     SIZE
+  | -- | storage quota exceeded
+    QUOTA
   | -- | incorrent file digest
     DIGEST
   | -- | file encryption/decryption failed
@@ -358,6 +360,7 @@ instance Encoding XFTPErrorType where
     CMD err -> "CMD " <> smpEncode err
     AUTH -> "AUTH"
     SIZE -> "SIZE"
+    QUOTA -> "QUOTA"
     DIGEST -> "DIGEST"
     CRYPTO -> "CRYPTO"
     NO_FILE -> "NO_FILE"
@@ -373,6 +376,7 @@ instance Encoding XFTPErrorType where
       "CMD" -> CMD <$> _smpP
       "AUTH" -> pure AUTH
       "SIZE" -> pure SIZE
+      "QUOTA" -> pure QUOTA
       "DIGEST" -> pure DIGEST
       "CRYPTO" -> pure CRYPTO
       "NO_FILE" -> pure NO_FILE
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 6fd8aa148..cf4b460ec 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -25,8 +25,10 @@ import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.List (intercalate)
 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 (getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Network.HTTP.Types as N
@@ -41,6 +43,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
+import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
 import Simplex.Messaging.Transport.HTTP2
@@ -68,7 +71,7 @@ runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpSer
 xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
 xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
   restoreServerStats
-  raceAny_ (runServer : serverStatsThread_ cfg) `finally` stopServer
+  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer
   where
     runServer :: M ()
     runServer = do
@@ -84,6 +87,29 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = 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 $ void $ atomically $ deleteFile st sId)
+      where
+        remove delete filePath =
+          ifM
+            (doesFileExist filePath)
+            (removeFile filePath >> delete `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
+            delete
+
     serverStatsThread_ :: XFTPServerConfig -> [M ()]
     serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
       [logServerStats logStatsStartTime interval serverStatsLogFile]
@@ -189,8 +215,9 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     -- TODO retry on duplicate IDs?
     sId <- getFileId
     rIds <- mapM (const getFileId) rcps
+    ts <- liftIO getSystemTime
     r <- runExceptT $ do
-      ExceptT $ atomically $ addFile st sId file
+      ExceptT $ atomically $ addFile st sId file ts
       forM (L.zip rIds rcps) $ \rcp ->
         ExceptT $ atomically $ addRecipient st sId rcp
     noFile $ either FRErr (const $ FRSndIds sId rIds) r
@@ -207,7 +234,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
   where
     noFile resp = pure (resp, Nothing)
     receiveServerFile :: FileRec -> M FileResponse
-    receiveServerFile FileRec {senderId, fileInfo, filePath} = case bodyPart of
+    receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
       -- TODO do not allow repeated file upload
       Nothing -> pure $ FRErr SIZE
       Just getBody -> do
@@ -215,10 +242,18 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         path <- asks $ filesPath . config
         let fPath = path </> B.unpack (B64.encode senderId)
             FileInfo {size, digest} = fileInfo
+        st <- asks store
+        quota_ <- asks $ fileSizeQuota . config
         liftIO $
           runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
-            Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk
-            Left e -> (whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError) $> FRErr e
+            Right () -> do
+              used <- readTVarIO $ usedStorage st
+              if maybe False (used + fromIntegral size >) quota_
+                then remove fPath $> FRErr QUOTA
+                else atomically (setFilePath' st fr fPath) $> 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 {filePath, fileInfo = FileInfo {size}} rDhKey = do
diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs
index 9147f1f20..e52f69965 100644
--- a/src/Simplex/FileTransfer/Server/Env.hs
+++ b/src/Simplex/FileTransfer/Server/Env.hs
@@ -3,12 +3,16 @@
 {-# 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.X509.Validation (Fingerprint (..))
@@ -19,8 +23,10 @@ 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 (RcvPublicVerifyKey)
+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
 
@@ -29,6 +35,14 @@ data XFTPServerConfig = XFTPServerConfig
     fileIdSize :: Int,
     storeLogFile :: Maybe FilePath,
     filesPath :: FilePath,
+    -- | server storage quota
+    fileSizeQuota :: Maybe Int64,
+    -- | 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,
@@ -51,11 +65,22 @@ data XFTPEnv = XFTPEnv
     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, caCertificateFile, certificateFile, privateKeyFile} = do
+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
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
index 5f3465698..42091f2de 100644
--- a/src/Simplex/FileTransfer/Server/Main.hs
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -14,8 +14,9 @@ import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Network.Socket (HostName)
 import Options.Applicative
+import Simplex.FileTransfer.Description (FileSize (..))
 import Simplex.FileTransfer.Server (runXFTPServer)
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
 import Simplex.Messaging.Server.CLI
@@ -72,33 +73,52 @@ xftpServerCLI cfgPath logPath = do
           \# 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\
+            <> "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\
+            <> "log_tls_errors: off\n\
+               \\n\
                \[FILES]\n"
             <> ("path: " <> filesPath <> "\n")
+            <> "# storage_quota: 100gb\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
-          cfg@XFTPServerConfig {xftpPort, storeLogFile} = serverConfig
           srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
       printServiceInfo serverVersion srv
-      printXFTPConfig xftpPort storeLogFile
-      runXFTPServer cfg
+      printXFTPConfig serverConfig
+      runXFTPServer serverConfig
       where
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
-        printXFTPConfig xftpPort logFile = do
-          putStrLn $ case logFile of
+        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 =
@@ -107,6 +127,10 @@ xftpServerCLI cfgPath logPath = do
               fileIdSize = 16,
               storeLogFile = enableStoreLog $> storeLogFilePath,
               filesPath = T.unpack $ strictIni "FILES" "path" ini,
+              fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini,
+              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,
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index 01d6f9a80..7bce800fe 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -9,9 +9,11 @@ module Simplex.FileTransfer.Server.Store
     newFileStore,
     addFile,
     setFilePath,
+    setFilePath',
     addRecipient,
     deleteFile,
     deleteRecipient,
+    expiredFilePath,
     getFile,
     ackFile,
   )
@@ -19,25 +21,29 @@ where
 
 import Control.Concurrent.STM
 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.Protocol (RcvPublicVerifyKey, RecipientId, SenderId)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM)
+import Simplex.Messaging.Util (ifM, ($>>=))
 
 data FileStore = FileStore
   { files :: TMap SenderId FileRec,
-    recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey)
+    recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey),
+    usedStorage :: TVar Int64
   }
 
 data FileRec = FileRec
   { senderId :: SenderId,
     fileInfo :: FileInfo,
     filePath :: TVar (Maybe FilePath),
-    recipientIds :: TVar (Set RecipientId)
+    recipientIds :: TVar (Set RecipientId),
+    createdAt :: SystemTime
   }
   deriving (Eq)
 
@@ -45,25 +51,30 @@ newFileStore :: STM FileStore
 newFileStore = do
   files <- TM.empty
   recipients <- TM.empty
-  pure FileStore {files, recipients}
+  usedStorage <- newTVar 0
+  pure FileStore {files, recipients, usedStorage}
 
-addFile :: FileStore -> SenderId -> FileInfo -> STM (Either XFTPErrorType ())
-addFile FileStore {files} sId fileInfo =
+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
+    f <- newFileRec sId fileInfo createdAt
     TM.insert sId f files
     pure $ Right ()
 
-newFileRec :: SenderId -> FileInfo -> STM FileRec
-newFileRec senderId fileInfo = do
+newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec
+newFileRec senderId fileInfo createdAt = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
-  pure FileRec {senderId, fileInfo, filePath, recipientIds}
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt}
 
 setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ())
 setFilePath st sId fPath =
-  withFile st sId $ \FileRec {filePath} ->
-    writeTVar filePath (Just fPath) $> Right ()
+  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 -> (RecipientId, RcvPublicVerifyKey) -> STM (Either XFTPErrorType ())
 addRecipient st@FileStore {recipients} senderId (rId, rKey) =
@@ -77,11 +88,13 @@ addRecipient st@FileStore {recipients} senderId (rId, rKey) =
         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} senderId = do
+deleteFile FileStore {files, recipients, usedStorage} senderId = do
   TM.lookupDelete senderId files >>= \case
-    Just FileRec {recipientIds} -> do
+    Just FileRec {fileInfo, recipientIds} -> do
       readTVar recipientIds >>= mapM_ (`TM.delete` recipients)
+      modifyTVar' usedStorage $ subtract (fromIntegral $ size fileInfo)
       pure $ Right ()
     _ -> pure $ Left AUTH
 
@@ -98,6 +111,14 @@ getFile st party fId = case party of
       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
diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs
index 4258c6784..37e6df390 100644
--- a/src/Simplex/FileTransfer/Server/StoreLog.hs
+++ b/src/Simplex/FileTransfer/Server/StoreLog.hs
@@ -22,11 +22,12 @@ 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.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
@@ -37,7 +38,7 @@ import System.Directory (doesFileExist, renameFile)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo
+  = AddFile SenderId FileInfo SystemTime
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty (RecipientId, RcvPublicVerifyKey))
   | DeleteFile SenderId
@@ -45,14 +46,14 @@ data FileStoreLogRecord
 
 instance StrEncoding FileStoreLogRecord where
   strEncode = \case
-    AddFile sId file -> strEncode (Str "FNEW", sId, file)
+    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),
+      [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP),
         "FPUT " *> (PutFile <$> strP_ <*> strP),
         "FADD " *> (AddRecipients <$> strP_ <*> strP),
         "FDEL " *> (DeleteFile <$> strP),
@@ -62,8 +63,8 @@ instance StrEncoding FileStoreLogRecord where
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> IO ()
-logAddFile s = logFileStoreRecord s .: AddFile
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO ()
+logAddFile s = logFileStoreRecord s .:. AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile
@@ -96,7 +97,7 @@ readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f
           Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
           _ -> pure ()
     addToStore = \case
-      AddFile sId file -> addFile st sId file
+      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
@@ -109,8 +110,8 @@ writeFileStore s FileStore {files, recipients} = do
   readTVarIO files >>= mapM_ (logFile allRcps)
   where
     logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO ()
-    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds} = do
-      logAddFile s senderId fileInfo
+    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
diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs
index 462274b47..6f393a018 100644
--- a/src/Simplex/Messaging/Server/CLI.hs
+++ b/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
 
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index b66ed5ba4..49a24a0bc 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/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
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index 6f7242126..ec1b67432 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -11,7 +11,7 @@ import Network.Socket (ServiceName)
 import SMPClient (serverBracket)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Server (runXFTPServerBlocking)
-import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration)
 import Simplex.Messaging.Protocol (XFTPServer)
 import Test.Hspec
 
@@ -77,6 +77,10 @@ testXFTPServerConfig =
       fileIdSize = 16,
       storeLogFile = Nothing,
       filesPath = xftpServerFiles,
+      fileSizeQuota = Nothing,
+      allowNewFiles = True,
+      newFileBasicAuth = Nothing,
+      fileExpiration = Just defaultFileExpiration,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 695101a96..e7a06fd89 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -7,6 +7,7 @@
 module XFTPServerTests where
 
 import AgentTests.FunctionalAPITests (runRight_)
+import Control.Concurrent (threadDelay)
 import Control.Exception (SomeException)
 import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
@@ -17,11 +18,13 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.List (isInfixOf)
 import Simplex.FileTransfer.Client
 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 (SenderId)
+import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.FilePath ((</>))
 import Test.Hspec
@@ -39,6 +42,8 @@ xftpServerTests =
       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 expire chunks after set interval" testFileChunkExpiration
+      it "should not allow uploading chunks after specified storage quota" testFileStorageQuota
 
 chSize :: Num n => n
 chSize = 128 * 1024
@@ -133,3 +138,53 @@ runTestFileChunkAck s r = do
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
   ackXFTPChunk r rpKey rId
     `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+
+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.sha512Hash <$> 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]
+    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.sha512Hash <$> 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]
+    uploadXFTPChunk c spKey sId1 chunkSpec
+    download rId1
+    (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey]
+    uploadXFTPChunk c spKey sId2 chunkSpec
+    download rId2
+
+    (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey]
+    uploadXFTPChunk c spKey sId3 chunkSpec
+      `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
+
+    deleteXFTPChunk c spKey sId1
+    uploadXFTPChunk c spKey sId3 chunkSpec
+    download rId3

From 202922bceb4cdd281eb9edb971276f2b6669f83c Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 24 Feb 2023 15:21:07 +0400
Subject: [PATCH 26/71] xftp: server store log (#652)

---
 src/Simplex/FileTransfer/Server.hs          | 22 +++++--
 src/Simplex/FileTransfer/Server/Store.hs    | 14 ++++-
 src/Simplex/FileTransfer/Server/StoreLog.hs |  6 +-
 src/Simplex/Messaging/Encoding/String.hs    |  6 +-
 tests/XFTPClient.hs                         |  9 +++
 tests/XFTPServerTests.hs                    | 69 ++++++++++++++++++++-
 6 files changed, 111 insertions(+), 15 deletions(-)

diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index cf4b460ec..38955fc4b 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -37,6 +37,7 @@ 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
@@ -45,7 +46,6 @@ import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
-import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Util
@@ -102,13 +102,16 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
         forM_ sIds $ \sId -> do
           threadDelay 100000
           atomically (expiredFilePath st sId old)
-            >>= mapM_ (remove $ void $ atomically $ deleteFile st sId)
+            >>= mapM_ (remove $ delete st sId)
       where
-        remove delete filePath =
+        remove del filePath =
           ifM
             (doesFileExist filePath)
-            (removeFile filePath >> delete `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
-            delete
+            (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} =
@@ -215,10 +218,14 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     -- TODO retry on duplicate IDs?
     sId <- getFileId
     rIds <- mapM (const getFileId) rcps
+    let rIdsKeys = L.zipWith FileRecipient rIds rcps
     ts <- liftIO getSystemTime
+    withFileLog $ \sl -> do
+      logAddFile sl sId file ts
+      logAddRecipients sl sId rIdsKeys
     r <- runExceptT $ do
       ExceptT $ atomically $ addFile st sId file ts
-      forM (L.zip rIds rcps) $ \rcp ->
+      forM rIdsKeys $ \rcp ->
         ExceptT $ atomically $ addRecipient st sId rcp
     noFile $ either FRErr (const $ FRSndIds sId rIds) r
   XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
@@ -242,6 +249,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         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
         liftIO $
@@ -269,6 +277,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
 
     deleteServerFile :: FileRec -> M FileResponse
     deleteServerFile FileRec {senderId, filePath} = do
+      withFileLog (`logDeleteFile` senderId)
       r <- runExceptT $ do
         path <- readTVarIO filePath
         ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p))
@@ -282,6 +291,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
 
     ackFileReception :: RecipientId -> FileRec -> M FileResponse
     ackFileReception rId fr = do
+      withFileLog (`logAckFile` rId)
       st <- asks store
       atomically $ deleteRecipient st rId fr
       pure FROk
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index 7bce800fe..2a19cb219 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -1,11 +1,13 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.FileTransfer.Server.Store
   ( FileStore (..),
     FileRec (..),
+    FileRecipient (..),
     newFileStore,
     addFile,
     setFilePath,
@@ -20,6 +22,7 @@ module Simplex.FileTransfer.Server.Store
 where
 
 import Control.Concurrent.STM
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Set (Set)
@@ -27,6 +30,7 @@ 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
@@ -47,6 +51,12 @@ data FileRec = FileRec
   }
   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
@@ -76,8 +86,8 @@ setFilePath' st FileRec {fileInfo, filePath} fPath = do
   writeTVar filePath (Just fPath)
   modifyTVar' (usedStorage st) (+ fromIntegral (size fileInfo))
 
-addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either XFTPErrorType ())
-addRecipient st@FileStore {recipients} senderId (rId, rKey) =
+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
diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs
index 37e6df390..dcfbb757e 100644
--- a/src/Simplex/FileTransfer/Server/StoreLog.hs
+++ b/src/Simplex/FileTransfer/Server/StoreLog.hs
@@ -40,7 +40,7 @@ import System.IO
 data FileStoreLogRecord
   = AddFile SenderId FileInfo SystemTime
   | PutFile SenderId FilePath
-  | AddRecipients SenderId (NonEmpty (RecipientId, RcvPublicVerifyKey))
+  | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
   | AckFile RecipientId
 
@@ -69,7 +69,7 @@ logAddFile s = logFileStoreRecord s .:. AddFile
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile
 
-logAddRecipients :: StoreLog 'WriteMode -> SenderId -> NonEmpty (RecipientId, RcvPublicVerifyKey) -> IO ()
+logAddRecipients :: StoreLog 'WriteMode -> SenderId -> NonEmpty FileRecipient -> IO ()
 logAddRecipients s = logFileStoreRecord s .: AddRecipients
 
 logDeleteFile :: StoreLog 'WriteMode -> SenderId -> IO ()
@@ -119,6 +119,6 @@ writeFileStore s FileStore {files, recipients} = do
       where
         getRcp rId = case M.lookup rId allRcps of
           Just (sndId, rKey)
-            | sndId == senderId -> Right (rId, 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"
diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs
index f35251348..e81b0da89 100644
--- a/src/Simplex/Messaging/Encoding/String.hs
+++ b/src/Simplex/Messaging/Encoding/String.hs
@@ -75,9 +75,9 @@ instance StrEncoding Str where
   strEncode = unStr
   strP = Str <$> A.takeTill (== ' ') <* optional A.space
 
-instance StrEncoding FilePath where
-  strEncode = strEncode
-  strDecode = strDecode
+instance StrEncoding String where
+  strEncode = strEncode . B.pack
+  strP = B.unpack <$> strP
 
 instance ToJSON Str where
   toJSON (Str s) = strToJSON s
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index ec1b67432..0a6430bad 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -37,12 +37,18 @@ runXFTPTestN nClients test = withXFTPServer $ run nClients []
     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}
+
 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
 
@@ -70,6 +76,9 @@ xftpServerFiles = "tests/tmp/xftp-server-files"
 xftpServerFiles2 :: FilePath
 xftpServerFiles2 = "tests/tmp/xftp-server-files2"
 
+testXFTPLogFile :: FilePath
+testXFTPLogFile = "tests/tmp/xftp-server-store.log"
+
 testXFTPServerConfig :: XFTPServerConfig
 testXFTPServerConfig =
   XFTPServerConfig
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index e7a06fd89..7d8129802 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -8,6 +8,7 @@ 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)
@@ -16,6 +17,7 @@ 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.Protocol (FileInfo (..), XFTPErrorType (..))
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
@@ -25,7 +27,7 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol (SenderId)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
-import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
 import Test.Hspec
 import XFTPClient
@@ -44,6 +46,7 @@ xftpServerTests =
       it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
       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
 
 chSize :: Num n => n
 chSize = 128 * 1024
@@ -188,3 +191,67 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
     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.sha512Hash <$> 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]
+    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
+
+  withXFTPServerThreadOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
+    sId <- liftIO $ readTVarIO sIdVar
+    rId1 <- liftIO $ readTVarIO rIdVar1
+    rId2 <- liftIO $ readTVarIO rIdVar2
+    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
+
+    download c rpKey1 rId1 digest bytes
+    ackXFTPChunk c rpKey1 rId1
+
+    download c rpKey2 rId2 digest bytes
+
+  logSize testXFTPLogFile `shouldReturn` 4
+
+  withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
+    sId <- liftIO $ readTVarIO sIdVar
+    deleteXFTPChunk c spKey sId
+
+  -- logSize testXFTPLogFile `shouldReturn` 0
+
+  -- liftIO $ threadDelay 60000000
+
+  removeFile testXFTPLogFile
+  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

From 8c8a984c1ca6149127751e222862c78b2d70c68e Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 24 Feb 2023 13:40:26 +0000
Subject: [PATCH 27/71] xftp: add basic auth (#653)

---
 src/Simplex/FileTransfer/Client.hs      |  8 ++--
 src/Simplex/FileTransfer/Client/Main.hs | 14 +++---
 src/Simplex/FileTransfer/Protocol.hs    |  9 ++--
 src/Simplex/FileTransfer/Server.hs      | 58 +++++++++++++++----------
 src/Simplex/FileTransfer/Server/Env.hs  |  2 +-
 src/Simplex/Messaging/Protocol.hs       |  5 ++-
 tests/XFTPServerTests.hs                | 47 +++++++++++++++-----
 7 files changed, 94 insertions(+), 49 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 27e0cdd70..cac7e68bc 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -33,7 +33,8 @@ import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Protocol
-  ( Protocol (..),
+  ( BasicAuth,
+    Protocol (..),
     ProtocolServer (..),
     RecipientId,
     SenderId,
@@ -128,9 +129,10 @@ createXFTPChunk ::
   C.APrivateSignKey ->
   FileInfo ->
   NonEmpty C.APublicVerifyKey ->
+  Maybe BasicAuth ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
-createXFTPChunk c spKey file rsps =
-  sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
+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
 
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 63939c296..e8d3cafcf 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -37,7 +37,7 @@ 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 (SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth)
 import Simplex.Messaging.Server.CLI (getCliCommand')
 import Simplex.Messaging.Util (ifM, whenM)
 import System.Exit (exitFailure)
@@ -79,7 +79,7 @@ data SendOptions = SendOptions
   { filePath :: FilePath,
     outputDir :: Maybe FilePath,
     numRecipients :: Int,
-    xftpServers :: [XFTPServer],
+    xftpServers :: [XFTPServerWithAuth],
     retryCount :: Int,
     tempPath :: Maybe FilePath
   }
@@ -113,7 +113,7 @@ data RandomFileOptions = RandomFileOptions
 defaultRetryCount :: Int
 defaultRetryCount = 3
 
-defaultXFTPServers :: NonEmpty XFTPServer
+defaultXFTPServers :: NonEmpty XFTPServerWithAuth
 defaultXFTPServers = L.fromList ["xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"]
 
 cliCommandP :: Parser CliCommand
@@ -275,14 +275,14 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       -- TODO unshuffle chunks
       pure $ map snd sentChunks
       where
-        uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
+        uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServerWithAuth -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
           (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
           rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
           chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
-          xftpServer <- liftIO $ getXFTPServer gen srvs
+          ProtoServerWithAuth xftpServer auth <- liftIO $ getXFTPServer gen srvs
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
+          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
           withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
           let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
               replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
@@ -293,7 +293,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
             hSeek h AbsoluteSeek $ fromIntegral chunkOffset
             digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
             pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
-        getXFTPServer :: TVar StdGen -> NonEmpty XFTPServer -> IO XFTPServer
+        getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
         getXFTPServer gen = \case
           srv :| [] -> pure srv
           servers -> do
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 21e5e1cbe..954b3e81b 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -31,7 +31,8 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
-  ( CommandError (..),
+  ( BasicAuth,
+    CommandError (..),
     Protocol (..),
     ProtocolEncoding (..),
     ProtocolErrorType (..),
@@ -157,7 +158,7 @@ instance Protocol XFTPErrorType FileResponse where
     _ -> Nothing
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
+  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FPSender
   FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
   FPUT :: FileCommand FPSender
   FDEL :: FileCommand FPSender
@@ -183,7 +184,7 @@ type XFTPFileId = ByteString
 instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
   encodeProtocol _v = \case
-    FNEW file rKeys -> e (FNEW_, ' ', file, rKeys)
+    FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
     FADD rKeys -> e (FADD_, ' ', rKeys)
     FPUT -> e FPUT_
     FDEL -> e FDEL_
@@ -220,7 +221,7 @@ instance ProtocolEncoding XFTPErrorType FileCmd where
   protocolP _v = \case
     FCT SSender tag ->
       FileCmd SSender <$> case tag of
-        FNEW_ -> FNEW <$> _smpP <*> smpP
+        FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 38955fc4b..027493360 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -24,6 +24,7 @@ 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
@@ -42,7 +43,7 @@ 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, RecipientId)
+import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
@@ -196,7 +197,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed
 verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
 verifyXFTPTransmission sig_ signed fId cmd =
   case cmd of
-    FileCmd SSender (FNEW file rcps) -> pure $ XFTPReqNew file rcps `verifyWith` sndKey file
+    FileCmd SSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
     FileCmd SRecipient PING -> pure $ VRVerified XFTPReqPing
     FileCmd party _ -> verifyCmd party
   where
@@ -212,34 +213,45 @@ verifyXFTPTransmission sig_ signed fId cmd =
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
-  XFTPReqNew file rcps -> do
-    st <- asks store
-    -- TODO validate body empty
-    -- TODO retry on duplicate IDs?
-    sId <- getFileId
-    rIds <- mapM (const getFileId) rcps
-    let rIdsKeys = L.zipWith FileRecipient rIds rcps
-    ts <- liftIO getSystemTime
-    withFileLog $ \sl -> do
-      logAddFile sl sId file ts
-      logAddRecipients sl sId rIdsKeys
-    r <- runExceptT $ do
-      ExceptT $ atomically $ addFile st sId file ts
-      forM rIdsKeys $ \rcp ->
-        ExceptT $ atomically $ addRecipient st sId rcp
-    noFile $ either FRErr (const $ FRSndIds sId rIds) r
+  XFTPReqNew file rcps auth ->
+    noFile
+      =<< ifM
+        allowNew
+        (createFile file rcps)
+        (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 -> (,Nothing) <$> receiveServerFile fr
-    FDEL -> (,Nothing) <$> deleteServerFile fr
+    FPUT -> noFile =<< receiveServerFile fr
+    FDEL -> noFile =<< deleteServerFile fr
     FGET rDhKey -> sendServerFile fr rDhKey
-    FACK -> (,Nothing) <$> ackFileReception fId fr
-    -- it should never get to the options below, they are passed in other constructors of XFTPRequest
-    FNEW _ _ -> noFile $ FRErr INTERNAL
+    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 :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    createFile file rcps = do
+      st <- asks store
+      -- TODO validate body empty
+      -- TODO retry on duplicate IDs?
+      sId <- getFileId
+      rIds <- mapM (const getFileId) rcps
+      let rIdsKeys = L.zipWith FileRecipient rIds rcps
+      ts <- liftIO getSystemTime
+      withFileLog $ \sl -> do
+        logAddFile sl sId file ts
+        logAddRecipients sl sId rIdsKeys
+      r <- runExceptT $ do
+        ExceptT $ atomically $ addFile st sId file ts
+        forM rIdsKeys $ \rcp ->
+          ExceptT $ atomically $ addRecipient st sId rcp
+      pure $ either FRErr (const $ FRSndIds sId rIds) r
     receiveServerFile :: FileRec -> M FileResponse
     receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
       -- TODO do not allow repeated file upload
diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs
index e52f69965..67ce8e08b 100644
--- a/src/Simplex/FileTransfer/Server/Env.hs
+++ b/src/Simplex/FileTransfer/Server/Env.hs
@@ -87,6 +87,6 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
   pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 data XFTPRequest
-  = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey)
+  = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth)
   | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 998c1c66a..94c5e28fe 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -76,6 +76,7 @@ module Simplex.Messaging.Protocol
     pattern NtfServer,
     XFTPServer,
     pattern XFTPServer,
+    XFTPServerWithAuth,
     ProtoServerWithAuth (..),
     BasicAuth (..),
     SrvLoc (..),
@@ -167,7 +168,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, (<$?>), eitherToMaybe)
+import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
@@ -632,6 +633,8 @@ 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' #-}
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 7d8129802..ca9d9d9bf 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -25,7 +25,7 @@ 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 (SenderId)
+import Simplex.Messaging.Protocol (BasicAuth, SenderId)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
@@ -47,6 +47,13 @@ xftpServerTests =
       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 :: Num n => n
 chSize = 128 * 1024
@@ -77,9 +84,9 @@ runTestFileChunkDelivery s r = do
   digest <- liftIO $ LC.sha512Hash <$> 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]
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
-  (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey]
+  (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
@@ -102,7 +109,7 @@ runTestFileChunkDelete s r = do
   digest <- liftIO $ LC.sha512Hash <$> 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]
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
 
   downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
@@ -130,7 +137,7 @@ runTestFileChunkAck s r = do
   digest <- liftIO $ LC.sha512Hash <$> 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]
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
   uploadXFTPChunk s spKey sId chunkSpec
 
   downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
@@ -151,7 +158,7 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
     digest <- liftIO $ LC.sha512Hash <$> 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]
+    (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId chunkSpec
 
     downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
@@ -177,14 +184,14 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
         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]
+    (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId1 chunkSpec
     download rId1
-    (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey]
+    (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId2 chunkSpec
     download rId2
 
-    (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey]
+    (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing
     uploadXFTPChunk c spKey sId3 chunkSpec
       `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
 
@@ -207,7 +214,7 @@ testFileLog = 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]
+    (sId, [rId1, rId2]) <- createXFTPChunk c spKey file [rcvKey1, rcvKey2] Nothing
     liftIO $
       atomically $ do
         writeTVar sIdVar sId
@@ -255,3 +262,23 @@ testFileLog = do
     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.sha512Hash <$> 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))

From f20a9967979ddfbbaead906483719213cdad6008 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 24 Feb 2023 18:34:01 +0400
Subject: [PATCH 28/71] xftp: more store log tests (#654)

---
 tests/XFTPServerTests.hs | 26 +++++++++++++++++---------
 1 file changed, 17 insertions(+), 9 deletions(-)

diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index ca9d9d9bf..b3aa4bd45 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -213,7 +213,6 @@ testFileLog = do
   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
@@ -221,16 +220,15 @@ testFileLog = do
         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
 
   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)
@@ -241,21 +239,31 @@ testFileLog = do
   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
 
+  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 testXFTPLogFile `shouldReturn` 0
-
-  -- liftIO $ threadDelay 60000000
+  withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start
+  logSize testXFTPLogFile `shouldReturn` 0
 
   removeFile testXFTPLogFile
   where

From 1b4b1845173fbd1e3e7445afd01e3c9050821c41 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Sat, 25 Feb 2023 21:55:58 +0400
Subject: [PATCH 29/71] xftp: server - retry on duplicate ids (#655)

* xftp: server - retry on duplicate ids (with commented monad code)

* remove commented code, refactor

* replace traverse with mapM

* refactor

* refactor

* refactor

* refactor

* refactor

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Server.hs | 55 +++++++++++++++++++-----------
 1 file changed, 35 insertions(+), 20 deletions(-)

diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 027493360..3c15c0e5c 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -8,7 +8,6 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 
 module Simplex.FileTransfer.Server where
 
@@ -29,7 +28,7 @@ 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 (getSystemTime)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Network.HTTP.Types as N
@@ -213,11 +212,12 @@ verifyXFTPTransmission sig_ signed fId cmd =
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
-  XFTPReqNew file rcps auth ->
+  XFTPReqNew file rks auth -> do
+    st <- asks store
     noFile
       =<< ifM
         allowNew
-        (createFile file rcps)
+        (createFile st file rks)
         (pure $ FRErr AUTH)
     where
       allowNew = do
@@ -235,23 +235,38 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
-    createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
-    createFile file rcps = do
-      st <- asks store
-      -- TODO validate body empty
-      -- TODO retry on duplicate IDs?
-      sId <- getFileId
-      rIds <- mapM (const getFileId) rcps
-      let rIdsKeys = L.zipWith FileRecipient rIds rcps
+    createFile :: FileStore -> FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    createFile st file rks = do
       ts <- liftIO getSystemTime
-      withFileLog $ \sl -> do
-        logAddFile sl sId file ts
-        logAddRecipients sl sId rIdsKeys
       r <- runExceptT $ do
-        ExceptT $ atomically $ addFile st sId file ts
-        forM rIdsKeys $ \rcp ->
-          ExceptT $ atomically $ addRecipient st sId rcp
-      pure $ either FRErr (const $ FRSndIds sId rIds) r
+        -- 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
+        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
@@ -316,7 +331,7 @@ randomId n = do
 getFileId :: M XFTPFileId
 getFileId = liftIO . getRandomBytes =<< asks (fileIdSize . config)
 
-withFileLog :: (StoreLog 'WriteMode -> IO a) -> M ()
+withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
 withFileLog action = liftIO . mapM_ action =<< asks storeLog
 
 incFileStat :: (FileServerStats -> TVar Int) -> M ()

From 3e9e144145cc23719811620ce398e878be89b30b Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 25 Feb 2023 19:51:33 +0000
Subject: [PATCH 30/71] ci: add xftp server (#657)

* ci: add xftp server

* add xftp
---
 .github/workflows/build.yml | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
index 536d67b85..740fbd58e 100644
--- a/.github/workflows/build.yml
+++ b/.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 }}

From c3872f0a559f6aa7bea153722c6962589f3e462d Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 25 Feb 2023 19:52:33 +0000
Subject: [PATCH 31/71] 5.0.0-beta.0

---
 package.yaml    | 2 +-
 simplexmq.cabal | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/package.yaml b/package.yaml
index 9ad64df97..fd23c72c2 100644
--- a/package.yaml
+++ b/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>,
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 72153441d..f88530698 100644
--- a/simplexmq.cabal
+++ b/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

From 781f8e000030fe709c0ca5929e6159c5b7474614 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 27 Feb 2023 13:42:15 +0000
Subject: [PATCH 32/71] xftp: increase timeouts for file uploads, show progress
 (#658)

* xftp: increase timeouts for file uploads, show progress

* refactor

* use default port 443

* typo

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* upload/download to/from chosen servers concurrently

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Client.hs            | 19 +++--
 src/Simplex/FileTransfer/Client/Main.hs       | 71 ++++++++++++------
 src/Simplex/FileTransfer/Server.hs            |  2 +
 src/Simplex/FileTransfer/Transport.hs         | 11 ++-
 .../Notifications/Server/Push/APNS.hs         |  2 +-
 src/Simplex/Messaging/Protocol.hs             |  4 +-
 .../Messaging/Transport/HTTP2/Client.hs       | 18 +++--
 tests/XFTPCLI.hs                              | 75 +++++++++++--------
 8 files changed, 130 insertions(+), 72 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index cac7e68bc..22ea9cd9d 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -53,7 +53,8 @@ data XFTPClient = XFTPClient
   }
 
 data XFTPClientConfig = XFTPClientConfig
-  { networkConfig :: NetworkConfig
+  { networkConfig :: NetworkConfig,
+    uploadTimeoutPerMb :: Int
   }
 
 data XFTPChunkBody = XFTPChunkBody
@@ -72,7 +73,11 @@ data XFTPChunkSpec = XFTPChunkSpec
 type XFTPClientError = ProtocolClientError XFTPErrorType
 
 defaultXFTPClientConfig :: XFTPClientConfig
-defaultXFTPClientConfig = XFTPClientConfig {networkConfig = defaultNetworkConfig}
+defaultXFTPClientConfig =
+  XFTPClientConfig
+    { networkConfig = defaultNetworkConfig,
+      uploadTimeoutPerMb = 10000000 -- 10 seconds
+    }
 
 getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either XFTPClientError XFTPClient)
 getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfig} disconnected = runExceptT $ do
@@ -81,7 +86,8 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfi
       username = proxyUsername transportSession
       ProtocolServer _ host port keyHash = srv
   useHost <- liftEither $ chooseTransportHost networkConfig host
-  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost port (Just keyHash) Nothing http2Config disconnected
+  let usePort = if null port then "443" else port
+  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config disconnected
   pure XFTPClient {http2Client, config}
 
 xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig
@@ -100,12 +106,13 @@ xftpClientError = \case
   HCIOError e -> PCEIOError e
 
 sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
-sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
+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
-  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req
+      reqTimeout = (\XFTPChunkSpec {chunkSize} -> (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb) <$> 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
@@ -115,6 +122,7 @@ sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fI
       _ -> pure (r, body)
     Left e -> throwError $ PCEResponseError e
   where
+    mb = 1024 * 1024
     streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
     streamBody t send done = do
       send $ byteString t
@@ -149,6 +157,7 @@ downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
       Just chunkPart -> do
         let dhSecret = C.dh' sDhKey rpDhKey
         cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
+        -- timeout download in the same way as upload
         withExceptT PCEResponseError $
           receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
             whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index e8d3cafcf..9558fce94 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -18,8 +18,9 @@ import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Function (on)
 import Data.Int (Int64)
-import Data.List (foldl', sortOn)
+import Data.List (foldl', groupBy, sortOn)
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
@@ -229,20 +230,23 @@ instance Encoding FileHeader where
 cliSendFile :: SendOptions -> ExceptT CLIError IO ()
 cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
   let (_, fileName) = splitFileName filePath
-  (encPath, fdRcv, fdSnd, chunkSpecs) <- encryptFile fileName
-  sentChunks <- uploadFile chunkSpecs
+  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFile 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'
-    putStrLn "File uploaded!\nPass file descriptions to the recipient(s):"
+    printNoNewLine "File uploaded!"
+    putStrLn "\nPass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
     putStrLn "Sender file description:"
     putStrLn fdSndPath
   where
-    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec])
+    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec], Int64)
     encryptFile fileName = do
       encPath <- getEncPath tempPath "xftp"
       key <- liftIO C.randomSbKey
@@ -251,13 +255,14 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
           chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
-          encSize = sum $ map fromIntegral chunkSizes
+          chunkSizes' = map fromIntegral chunkSizes
+          encSize = sum chunkSizes'
       encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
           fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
           fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
-      pure (encPath, fdRcv, fdSnd, chunkSpecs)
+      pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
       where
         encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
         encrypt fileHdr key nonce fileSize' encSize encFile = do
@@ -265,25 +270,30 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
           let f' = LB.fromStrict fileHdr <> f
           c <- liftEither $ first (CLIError . show) $ LC.sbEncryptTailTag key nonce f' fileSize' $ encSize - authTagSize
           liftIO $ LB.writeFile encFile c
-    uploadFile :: [XFTPChunkSpec] -> ExceptT CLIError IO [SentFileChunk]
-    uploadFile chunks = do
+    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)
-      -- TODO shuffle chunks
-      sentChunks <- pooledForConcurrentlyN 32 (zip [1 ..] chunks) $ uploadFileChunk a gen xftpSrvs
-      -- TODO unshuffle chunks
-      pure $ map snd sentChunks
+      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).
+      map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 chunks' (mapM $ uploadFileChunk a)
       where
-        uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServerWithAuth -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
-        uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
+        uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
+        uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
           (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
           rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
           chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
-          ProtoServerWithAuth xftpServer auth <- liftIO $ getXFTPServer gen srvs
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
           (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
           withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
+          uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
+            let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
+          liftIO $ printProgress "Uploaded" uploaded encSize
           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})
@@ -370,7 +380,11 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       encPath <- getEncPath tempPath "xftp"
       createDirectory encPath
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
-      chunkPaths <- forM chunks $ downloadFileChunk a encPath
+      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
@@ -378,17 +392,20 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       path <- decryptFile encSize chunkPaths key nonce
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
-      liftIO $ putStrLn $ "File received: " <> path
-      liftIO $ putStrLn "File description cannot be used again"
-    downloadFileChunk :: XFTPClientAgent -> FilePath -> FileChunk -> ExceptT CLIError IO FilePath
-    downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
+      liftIO $ printNoNewLine $ "File downloaded: " <> path
+      liftIO $ putStrLn "\nFile description can't be used again"
+    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
       chunkPath <- uniqueCombine encPath $ show chunkNo
       c <- withRetry retryCount $ getXFTPServerClient a server
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
       withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
-      pure chunkPath
-    downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
+      downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
+        let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
+      liftIO $ printProgress "Downloaded" downloaded encSize
+      pure (chunkNo, chunkPath)
+    downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
     decryptFile encSize chunkPaths key nonce = do
       (authOk, f) <- liftEither . first (CLIError . show) . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
@@ -422,6 +439,14 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
       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} = do
   getFileDescription' fileDescription >>= deleteFile
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 3c15c0e5c..26ad3e7ee 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -187,6 +187,7 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
               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
@@ -279,6 +280,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         withFileLog $ \sl -> logPutFile sl senderId fPath
         st <- asks store
         quota_ <- asks $ fileSizeQuota . config
+        -- TODO timeout file upload, remove partially uploaded files
         liftIO $
           runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
             Right () -> do
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index ad94b551d..75be16406 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -41,6 +41,9 @@ data XFTPRcvChunkSpec = XFTPRcvChunkSpec
 supportedFileServerVRange :: VersionRange
 supportedFileServerVRange = mkVersionRange 1 1
 
+fileBlockSize :: Int
+fileBlockSize = 16 * 1024
+
 sendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
 sendFile h send = go
   where
@@ -55,7 +58,7 @@ sendEncFile h send = go
   where
     go sbState 0 = do
       -- TODO remove padding when HTTP2 issue is fixed
-      let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (xftpBlockSize - C.authTagSize) '#'
+      let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (fileBlockSize - C.authTagSize) '#'
       send $ byteString authTag
     go sbState sz =
       getFileChunk h sz >>= \ch -> do
@@ -67,7 +70,7 @@ sendEncFile h send = go
 
 getFileChunk :: Handle -> Word32 -> IO ByteString
 getFileChunk h sz =
-  B.hGet h xftpBlockSize >>= \case
+  B.hGet h fileBlockSize >>= \case
     "" -> ioe_EOF
     ch -> pure $ B.take (fromIntegral sz) ch -- sz >= xftpBlockSize
 
@@ -75,7 +78,7 @@ receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorTy
 receiveFile getBody = receiveFile_ receive
   where
     receive h sz = do
-      ch <- getBody xftpBlockSize
+      ch <- getBody fileBlockSize
       let chSize = fromIntegral $ B.length ch
       if
           | chSize > sz -> pure $ Left SIZE
@@ -87,7 +90,7 @@ receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> Ex
 receiveEncFile getBody = receiveFile_ . receive
   where
     receive sbState h sz = do
-      ch <- getBody xftpBlockSize
+      ch <- getBody fileBlockSize
       let chSize = fromIntegral $ B.length ch
       if
           | chSize > sz + authSz -> pure $ Left SIZE
diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
index ae4e3453d..0b4b0f572 100644
--- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
@@ -344,7 +344,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
   req <- liftIO $ apnsRequest c tknStr apnsNtf
   -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
-  HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req
+  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'
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 94c5e28fe..5f23b1601 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -755,7 +755,7 @@ 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
 
@@ -775,7 +775,7 @@ 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
diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs
index 53f2f18f4..66d88f6c9 100644
--- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs
+++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs
@@ -123,15 +123,18 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien
 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))
 
-sendRequestDirect :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
-sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req =
-  connTimeout config `timeout` try (sendReq req process) >>= \case
+-- | 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
@@ -140,6 +143,9 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
       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
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index d93660baf..7fd58e681 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -2,7 +2,7 @@ module XFTPCLI where
 
 import Control.Exception (bracket_)
 import qualified Data.ByteString as LB
-import Data.List (isInfixOf)
+import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
 import Simplex.FileTransfer.Client.Main (xftpClientCLI)
 import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive)
 import System.Environment (withArgs)
@@ -43,14 +43,15 @@ testXFTPCLISendReceive = withXFTPServer $ do
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
-  xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
-    `shouldReturn` [ "File uploaded!",
-                     "Pass file descriptions to the recipient(s):",
-                     fdRcv1,
-                     fdRcv2,
-                     "Sender file description:",
-                     fdSnd
-                   ]
+  progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+                 fdRcv1,
+                 fdRcv2,
+                 "Sender file description:",
+                 fdSnd
+               ]
   testInfoFile fdRcv1 "Recipient"
   testReceiveFile fdRcv1 "testfile" file
   testInfoFile fdRcv2 "Recipient"
@@ -64,8 +65,9 @@ testXFTPCLISendReceive = withXFTPServer $ do
       xftp ["info", fd]
         `shouldReturn` [party <> " file description", "File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
     testReceiveFile fd fileName file = do
-      xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
-        `shouldReturn` ["File received: " <> recipientFiles </> fileName, "File description cannot be used again"]
+      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+      progress `shouldSatisfy` downloadProgress fileName
+      recvResult `shouldBe` ["File description can't be used again"]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLISendReceive2servers :: IO ()
@@ -77,14 +79,15 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
-  xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
-    `shouldReturn` [ "File uploaded!",
-                     "Pass file descriptions to the recipient(s):",
-                     fdRcv1,
-                     fdRcv2,
-                     "Sender file description:",
-                     fdSnd
-                   ]
+  progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+                 fdRcv1,
+                 fdRcv2,
+                 "Sender file description:",
+                 fdSnd
+               ]
   testReceiveFile fdRcv1 "testfile" file
   testReceiveFile fdRcv2 "testfile_1" file
   where
@@ -100,8 +103,9 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
           srv1 `shouldContain` testXFTPServerStr
           srv2 `shouldContain` testXFTPServerStr2
         _ -> print srvs >> error "more than 2 servers returned"
-      xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
-        `shouldReturn` ["File received: " <> recipientFiles </> fileName, "File description cannot be used again"]
+      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+      progress `shouldSatisfy` downloadProgress fileName
+      recvResult `shouldBe` ["File description can't be used again"]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLIDelete :: IO ()
@@ -113,18 +117,20 @@ testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
-  xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
-    `shouldReturn` [ "File uploaded!",
-                     "Pass file descriptions to the recipient(s):",
-                     fdRcv1,
-                     fdRcv2,
-                     "Sender file description:",
-                     fdSnd
-                   ]
+  progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress `shouldSatisfy` uploadProgress
+  sendResult
+    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+                 fdRcv1,
+                 fdRcv2,
+                 "Sender file description:",
+                 fdSnd
+               ]
   xftp ["del", fdRcv1]
     `shouldThrow` anyException
-  xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp"]
-    `shouldReturn` ["File received: " <> recipientFiles </> "testfile", "File description cannot be used again"]
+  progress1 : recvResult <- xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp"]
+  progress1 `shouldSatisfy` downloadProgress "testfile"
+  recvResult `shouldBe` ["File description can't be used again"]
   LB.readFile (recipientFiles </> "testfile") `shouldReturn` file
   fs1 <- listDirectory xftpServerFiles
   fs2 <- listDirectory xftpServerFiles2
@@ -137,3 +143,10 @@ testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
     `shouldThrow` anyException
   where
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
+
+uploadProgress :: String -> Bool
+uploadProgress s = "Uploading file..." `isPrefixOf` s && "File uploaded!" `isInfixOf` s
+
+downloadProgress :: FilePath -> String -> Bool
+downloadProgress fileName s =
+  "Downloading file..." `isPrefixOf` s && ("File downloaded: " <> recipientFiles </> fileName <> "\r") `isSuffixOf` s

From 2f15ce26629cbef5dc134083936fdc53badaa90e Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 27 Feb 2023 18:01:18 +0000
Subject: [PATCH 33/71] xftp: add quota param to server CLI, restrict chunk
 sizes (#659)

* xftp: add quota param to server CLI

* only allow certain file sizes, fix tests
---
 src/Simplex/FileTransfer/Client.hs      |  2 +-
 src/Simplex/FileTransfer/Client/Main.hs |  5 +---
 src/Simplex/FileTransfer/Description.hs | 33 ++++++++++++++++---------
 src/Simplex/FileTransfer/Server.hs      |  4 ++-
 src/Simplex/FileTransfer/Server/Env.hs  |  3 +++
 src/Simplex/FileTransfer/Server/Main.hs | 19 +++++++++++---
 src/Simplex/FileTransfer/Transport.hs   |  2 +-
 tests/CLITests.hs                       |  2 +-
 tests/FileDescriptionTests.hs           |  3 ---
 tests/XFTPCLI.hs                        | 20 +++++++--------
 tests/XFTPClient.hs                     |  2 ++
 tests/XFTPServerTests.hs                | 16 ++++++++++--
 12 files changed, 72 insertions(+), 39 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 22ea9cd9d..4a2cc7500 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -19,6 +19,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 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
@@ -122,7 +123,6 @@ sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}}
       _ -> pure (r, body)
     Left e -> throwError $ PCEResponseError e
   where
-    mb = 1024 * 1024
     streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO ()
     streamBody t send done = do
       send $ byteString t
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 9558fce94..fd463e189 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -52,7 +52,7 @@ xftpClientVersion :: String
 xftpClientVersion = "0.1.0"
 
 defaultChunkSize :: Word32
-defaultChunkSize = 8 * mb
+defaultChunkSize = 4 * mb
 
 smallChunkSize :: Word32
 smallChunkSize = 1 * mb
@@ -63,9 +63,6 @@ fileSizeLen = 8
 authTagSize :: Int64
 authTagSize = fromIntegral C.authTagSize
 
-mb :: Num a => a
-mb = 1024 * 1024
-
 newtype CLIError = CLIError String
   deriving (Eq, Show, Exception)
 
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 7b3eee7e9..70c4d3fe1 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -9,7 +9,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
@@ -28,6 +27,9 @@ module Simplex.FileTransfer.Description
     validateFileDescription,
     groupReplicasByServer,
     replicaServer,
+    kb,
+    mb,
+    gb,
   )
 where
 
@@ -46,6 +48,7 @@ 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 GHC.Generics (Generic)
@@ -195,13 +198,13 @@ newtype FileSize a = FileSize {unFileSize :: a}
 instance (Integral a, Show a) => StrEncoding (FileSize a) where
   strEncode (FileSize b)
     | b' /= 0 = bshow b
-    | kb' /= 0 = bshow kb <> "kb"
-    | mb' /= 0 = bshow mb <> "mb"
-    | otherwise = bshow gb <> "gb"
+    | ks' /= 0 = bshow ks <> "kb"
+    | ms' /= 0 = bshow ms <> "mb"
+    | otherwise = bshow gs <> "gb"
     where
-      (kb, b') = b `divMod` 1024
-      (mb, kb') = kb `divMod` 1024
-      (gb, mb') = mb `divMod` 1024
+      (ks, b') = b `divMod` 1024
+      (ms, ks') = ks `divMod` 1024
+      (gs, ms') = ms `divMod` 1024
   strP =
     FileSize
       <$> A.choice
@@ -210,10 +213,18 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
           (kb *) <$> A.decimal <* "kb",
           A.decimal
         ]
-    where
-      kb = 1024
-      mb = 1024 * kb
-      gb = 1024 * mb
+
+kb :: Integral a => a
+kb = 1024
+
+mb :: Integral a => a
+mb = 1024 * kb
+
+gb :: Integral a => a
+gb = 1024 * mb
+
+instance (Integral a, Show a) => IsString (FileSize a) where
+  fromString = either error id . strDecode . B.pack
 
 groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
 groupReplicasByServer defChunkSize =
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index 26ad3e7ee..a6f32d481 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -238,8 +238,10 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     noFile resp = pure (resp, Nothing)
     createFile :: FileStore -> FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
     createFile st file rks = do
-      ts <- liftIO getSystemTime
       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
diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs
index 67ce8e08b..08ddf9ade 100644
--- a/src/Simplex/FileTransfer/Server/Env.hs
+++ b/src/Simplex/FileTransfer/Server/Env.hs
@@ -15,6 +15,7 @@ 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
@@ -37,6 +38,8 @@ data XFTPServerConfig = XFTPServerConfig
     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
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
index 42091f2de..4ee79d958 100644
--- a/src/Simplex/FileTransfer/Server/Main.hs
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -7,17 +7,20 @@
 
 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 (..))
+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 (..))
@@ -51,7 +54,7 @@ xftpServerCLI cfgPath logPath = do
     defaultServerPort = "443"
     executableName = "file-server"
     storeLogFilePath = combine logPath "file-server-store.log"
-    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath} = do
+    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota} = do
       clearDirIfExists cfgPath
       clearDirIfExists logPath
       createDirectoryIfMissing True cfgPath
@@ -95,7 +98,7 @@ xftpServerCLI cfgPath logPath = do
                \\n\
                \[FILES]\n"
             <> ("path: " <> filesPath <> "\n")
-            <> "# storage_quota: 100gb\n"
+            <> ("storage_quota: " <> B.unpack (strEncode fileSizeQuota) <> "\n")
     runServer ini = do
       hSetBuffering stdout LineBuffering
       hSetBuffering stderr LineBuffering
@@ -128,6 +131,7 @@ xftpServerCLI cfgPath logPath = do
               storeLogFile = enableStoreLog $> storeLogFilePath,
               filesPath = T.unpack $ strictIni "FILES" "path" ini,
               fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini,
+              allowedChunkSizes = [256 * kb, 1 * mb, 4 * mb],
               allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
               newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
               fileExpiration = Just defaultFileExpiration,
@@ -151,7 +155,8 @@ data InitOptions = InitOptions
     signAlgorithm :: SignAlgorithm,
     ip :: HostName,
     fqdn :: Maybe HostName,
-    filesPath :: FilePath
+    filesPath :: FilePath,
+    fileSizeQuota :: FileSize Int64
   }
   deriving (Show)
 
@@ -201,3 +206,9 @@ cliCommandP cfgPath logPath iniFile =
               <> help "Path to the directory to store files"
               <> metavar "PATH"
           )
+        <*> strOption
+          ( long "quota"
+              <> short 'q'
+              <> help "File storage quota (e.g. 100gb)"
+              <> metavar "QUOTA"
+          )
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index 75be16406..da43c2fc6 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -25,7 +25,7 @@ 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 (..), xftpBlockSize)
+import Simplex.FileTransfer.Protocol (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Version
diff --git a/tests/CLITests.hs b/tests/CLITests.hs
index 44ef4022c..40915515b 100644
--- a/tests/CLITests.hs
+++ b/tests/CLITests.hs
@@ -91,7 +91,7 @@ ntfServerTest storeLog = do
 
 xftpServerTest :: Bool -> IO ()
 xftpServerTest storeLog = do
-  capture_ (withArgs (["init", "-p tests/tmp"] <> ["-l" | storeLog]) $ xftpServerCLI fileCfgPath fileLogPath)
+  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")
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
index f8425ce44..cd20448fa 100644
--- a/tests/FileDescriptionTests.hs
+++ b/tests/FileDescriptionTests.hs
@@ -30,9 +30,6 @@ fileDescPath = "tests/fixtures/file_description.yaml"
 tmpFileDescPath :: FilePath
 tmpFileDescPath = "tests/tmp/file_description.yaml"
 
-mb :: Num a => a
-mb = 1024 * 1024
-
 testSbKey :: C.SbKey
 testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY="
 
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 7fd58e681..0b412ab83 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -4,6 +4,7 @@ import Control.Exception (bracket_)
 import qualified Data.ByteString as LB
 import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
 import Simplex.FileTransfer.Client.Main (xftpClientCLI)
+import Simplex.FileTransfer.Description (mb)
 import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive)
 import System.Environment (withArgs)
 import System.FilePath ((</>))
@@ -31,15 +32,12 @@ senderFiles = "tests/tmp/xftp-sender-files"
 recipientFiles :: FilePath
 recipientFiles = "tests/tmp/xftp-recipient-files"
 
-mb :: Num a => a
-mb = 1024 * 1024
-
 testXFTPCLISendReceive :: IO ()
 testXFTPCLISendReceive = withXFTPServer $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
+  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
-  getFileSize filePath `shouldReturn` 19 * mb
+  getFileSize filePath `shouldReturn` 17 * mb
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -63,7 +61,7 @@ testXFTPCLISendReceive = withXFTPServer $ do
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testInfoFile fd party = do
       xftp ["info", fd]
-        `shouldReturn` [party <> " file description", "File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
+        `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
     testReceiveFile fd fileName file = do
       progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
       progress `shouldSatisfy` downloadProgress fileName
@@ -73,9 +71,9 @@ testXFTPCLISendReceive = withXFTPServer $ do
 testXFTPCLISendReceive2servers :: IO ()
 testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
+  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
-  getFileSize filePath `shouldReturn` 19 * mb
+  getFileSize filePath `shouldReturn` 17 * mb
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -95,7 +93,7 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
     testReceiveFile fd fileName file = do
       partyStr : sizeStr : srvStr : srvs <- xftp ["info", fd]
       partyStr `shouldContain` "Recipient file description"
-      sizeStr `shouldBe` "File download size: 20mb"
+      sizeStr `shouldBe` "File download size: 18mb"
       srvStr `shouldBe` "File server(s):"
       case srvs of
         [srv1] -> any (`isInfixOf` srv1) [testXFTPServerStr, testXFTPServerStr2] `shouldBe` True
@@ -111,9 +109,9 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
 testXFTPCLIDelete :: IO ()
 testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
+  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
-  getFileSize filePath `shouldReturn` 19 * mb
+  getFileSize filePath `shouldReturn` 17 * mb
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index 0a6430bad..44864382b 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -10,6 +10,7 @@ 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)
@@ -87,6 +88,7 @@ testXFTPServerConfig =
       storeLogFile = Nothing,
       filesPath = xftpServerFiles,
       fileSizeQuota = Nothing,
+      allowedChunkSizes = [128 * kb, 256 * kb, 1 * mb, 4 * mb],
       allowNewFiles = True,
       newFileBasicAuth = Nothing,
       fileExpiration = Just defaultFileExpiration,
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index b3aa4bd45..abb91cb71 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -19,6 +19,7 @@ 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 (..))
@@ -44,6 +45,7 @@ xftpServerTests =
       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
@@ -55,8 +57,8 @@ xftpServerTests =
         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 :: Num n => n
-chSize = 128 * 1024
+chSize :: Integral a => a
+chSize = 128 * kb
 
 testChunkPath :: FilePath
 testChunkPath = "tests/tmp/chunk1"
@@ -149,6 +151,16 @@ runTestFileChunkAck s r = do
   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 (96 * kb)
+  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = 96 * kb, digest}
+  void (createXFTPChunk c spKey file [rcvKey] Nothing)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
+
 testFileChunkExpiration :: Expectation
 testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $
   \_ -> testXFTPClient $ \c -> runRight_ $ do

From f02cb2da4c0a5aabedc106a034bf360bf905215c Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 27 Feb 2023 18:04:00 +0000
Subject: [PATCH 34/71] 5.0.0-beta.1


From 875a4bac5eb1f33474ec7d9ae7816ba91a1d6193 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 27 Feb 2023 21:15:22 +0000
Subject: [PATCH 35/71] xftp cli: use 3 chunk sizes (256kb, 1mb, 4mb) (#660)

* xftp cli: use 3 chunk sizes (256kb, 1mb, 4mb)

* hardcode default servers

* disable rand command

* hide rand command instead of removing
---
 src/Simplex/FileTransfer/Client.hs      |  2 +-
 src/Simplex/FileTransfer/Client/Main.hs | 61 ++++++++++++++++---------
 src/Simplex/FileTransfer/Description.hs | 18 ++++----
 src/Simplex/FileTransfer/Server/Main.hs |  2 +-
 tests/FileDescriptionTests.hs           |  6 +--
 tests/XFTPCLI.hs                        | 28 ++++++++++--
 tests/XFTPClient.hs                     |  2 +-
 tests/XFTPServerTests.hs                |  6 +--
 8 files changed, 81 insertions(+), 44 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 4a2cc7500..6b073b308 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -112,7 +112,7 @@ sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}}
     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) <$> chunkSpec_
+      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?
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index fd463e189..f1c777177 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -7,7 +7,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Simplex.FileTransfer.Client.Main (xftpClientCLI) where
+module Simplex.FileTransfer.Client.Main
+  ( xftpClientCLI,
+    prepareChunkSizes,
+  )
+where
 
 import Control.Concurrent.STM (stateTVar)
 import Control.Monad
@@ -51,11 +55,14 @@ import UnliftIO.Directory
 xftpClientVersion :: String
 xftpClientVersion = "0.1.0"
 
-defaultChunkSize :: Word32
-defaultChunkSize = 4 * mb
+chunkSize1 :: Word32
+chunkSize1 = kb 256
 
-smallChunkSize :: Word32
-smallChunkSize = 1 * mb
+chunkSize2 :: Word32
+chunkSize2 = mb 1
+
+chunkSize3 :: Word32
+chunkSize3 = mb 4
 
 fileSizeLen :: Int64
 fileSizeLen = 8
@@ -112,7 +119,15 @@ defaultRetryCount :: Int
 defaultRetryCount = 3
 
 defaultXFTPServers :: NonEmpty XFTPServerWithAuth
-defaultXFTPServers = L.fromList ["xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"]
+defaultXFTPServers =
+  L.fromList
+    [ "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"
+    ]
 
 cliCommandP :: Parser CliCommand
 cliCommandP =
@@ -121,8 +136,8 @@ cliCommandP =
         <> 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"))
-        <> command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size"))
     )
+    <|> hsubparser (command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size")) <> internal)
   where
     sendP :: Parser SendOptions
     sendP =
@@ -151,8 +166,7 @@ cliCommandP =
     randomP =
       RandomFileOptions
         <$> argument str (metavar "FILE" <> help "Path to save file")
-        <*> argument strDec (metavar "SIZE" <> help "File size (bytes/kb/mb/gb)")
-    strDec = eitherReader $ strDecode . B.pack
+        <*> 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)")
@@ -252,13 +266,14 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       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'
       encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
-          fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
-          fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
+          fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+          fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
       where
         encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
@@ -493,15 +508,18 @@ getFileDescription' path =
     AVFD fd -> either (throwError . CLIError) pure $ checkParty fd
 
 prepareChunkSizes :: Int64 -> [Word32]
-prepareChunkSizes 0 = []
-prepareChunkSizes size
-  | size >= defSz = replicate (fromIntegral n1) defaultChunkSize <> prepareChunkSizes remSz
-  | size > defSz `div` 2 = [defaultChunkSize]
-  | otherwise = replicate (fromIntegral n2') smallChunkSize
+prepareChunkSizes size' = prepareSizes size'
   where
-    (n1, remSz) = size `divMod` defSz
-    n2' = let (n2, remSz2) = (size `divMod` fromIntegral smallChunkSize) in if remSz2 == 0 then n2 else n2 + 1
-    defSz = fromIntegral defaultChunkSize :: Int64
+    (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
@@ -537,6 +555,7 @@ cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
   putStrLn $ "File created: " <> filePath
   where
     saveRandomFile h sz = do
-      bytes <- getRandomBytes $ min mb sz
+      bytes <- getRandomBytes $ min mb' sz
       B.hPut h bytes
-      when (sz > mb) $ saveRandomFile h (sz - mb)
+      when (sz > mb') $ saveRandomFile h (sz - mb')
+    mb' = mb 1
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index 70c4d3fe1..cee74ff9a 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -208,20 +208,20 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
   strP =
     FileSize
       <$> A.choice
-        [ (gb *) <$> A.decimal <* "gb",
-          (mb *) <$> A.decimal <* "mb",
-          (kb *) <$> A.decimal <* "kb",
+        [ gb <$> A.decimal <* "gb",
+          mb <$> A.decimal <* "mb",
+          kb <$> A.decimal <* "kb",
           A.decimal
         ]
 
-kb :: Integral a => a
-kb = 1024
+kb :: Integral a => a -> a
+kb n = 1024 * n
 
-mb :: Integral a => a
-mb = 1024 * kb
+mb :: Integral a => a -> a
+mb n = 1024 * kb n
 
-gb :: Integral a => a
-gb = 1024 * mb
+gb :: Integral a => a -> a
+gb n = 1024 * mb n
 
 instance (Integral a, Show a) => IsString (FileSize a) where
   fromString = either error id . strDecode . B.pack
diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs
index 4ee79d958..4c3d6e1fb 100644
--- a/src/Simplex/FileTransfer/Server/Main.hs
+++ b/src/Simplex/FileTransfer/Server/Main.hs
@@ -131,7 +131,7 @@ xftpServerCLI cfgPath logPath = do
               storeLogFile = enableStoreLog $> storeLogFilePath,
               filesPath = T.unpack $ strictIni "FILES" "path" ini,
               fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini,
-              allowedChunkSizes = [256 * kb, 1 * mb, 4 * mb],
+              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,
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
index cd20448fa..f02945406 100644
--- a/tests/FileDescriptionTests.hs
+++ b/tests/FileDescriptionTests.hs
@@ -40,7 +40,7 @@ fileDesc :: FileDescription 'FPRecipient
 fileDesc =
   FileDescription
     { party = SRecipient,
-      size = FileSize $ 26 * mb,
+      size = FileSize $ mb 26,
       digest = FileDigest "abc",
       key = testSbKey,
       nonce = testCbNonce,
@@ -76,7 +76,7 @@ fileDesc =
           FileChunk
             { chunkNo = 4,
               digest = chunkDigest,
-              chunkSize = FileSize $ 2 * mb,
+              chunkSize = FileSize $ mb 2,
               replicas =
                 [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
                   FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
@@ -85,7 +85,7 @@ fileDesc =
         ]
     }
   where
-    defaultChunkSize = FileSize $ 8 * mb
+    defaultChunkSize = FileSize $ mb 8
     replicaId = ChunkReplicaId "abc"
     replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
     chunkDigest = FileDigest "ghi"
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 0b412ab83..535b3ebb9 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -3,8 +3,8 @@ module XFTPCLI where
 import Control.Exception (bracket_)
 import qualified Data.ByteString as LB
 import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
-import Simplex.FileTransfer.Client.Main (xftpClientCLI)
-import Simplex.FileTransfer.Description (mb)
+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 ((</>))
@@ -17,6 +17,7 @@ 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 =
@@ -37,7 +38,7 @@ testXFTPCLISendReceive = withXFTPServer $ do
   let filePath = senderFiles </> "testfile"
   xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
-  getFileSize filePath `shouldReturn` 17 * mb
+  getFileSize filePath `shouldReturn` mb 17
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -73,7 +74,7 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
   xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
-  getFileSize filePath `shouldReturn` 17 * mb
+  getFileSize filePath `shouldReturn` mb 17
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -111,7 +112,7 @@ testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
   xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
   file <- LB.readFile filePath
-  getFileSize filePath `shouldReturn` 17 * mb
+  getFileSize filePath `shouldReturn` mb 17
   let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
       fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -142,6 +143,23 @@ testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   where
     xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
 
+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 = "Uploading file..." `isPrefixOf` s && "File uploaded!" `isInfixOf` s
 
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index 44864382b..4fcc21c40 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -88,7 +88,7 @@ testXFTPServerConfig =
       storeLogFile = Nothing,
       filesPath = xftpServerFiles,
       fileSizeQuota = Nothing,
-      allowedChunkSizes = [128 * kb, 256 * kb, 1 * mb, 4 * mb],
+      allowedChunkSizes = [kb 128, kb 256, mb 1, mb 4],
       allowNewFiles = True,
       newFileBasicAuth = Nothing,
       fileExpiration = Just defaultFileExpiration,
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index abb91cb71..3ec2a33c9 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -58,7 +58,7 @@ xftpServerTests =
         it "allowed with auth on server without auth" $ testFileBasicAuth True Nothing (Just "any") True
 
 chSize :: Integral a => a
-chSize = 128 * kb
+chSize = kb 128
 
 testChunkPath :: FilePath
 testChunkPath = "tests/tmp/chunk1"
@@ -155,9 +155,9 @@ 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 (96 * kb)
+  liftIO $ B.writeFile testChunkPath =<< getRandomBytes (kb 96)
   digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
-  let file = FileInfo {sndKey, size = 96 * kb, digest}
+  let file = FileInfo {sndKey, size = kb 96, digest}
   void (createXFTPChunk c spKey file [rcvKey] Nothing)
     `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
 

From 524c1de4dea9509975ea48a390022a3a6507f1db Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 28 Feb 2023 08:59:28 +0000
Subject: [PATCH 36/71] xftp: server stats (#661)

---
 src/Simplex/FileTransfer/Server.hs       | 48 +++++++++++++++++++-----
 src/Simplex/FileTransfer/Server/Stats.hs | 27 +++++++++----
 tests/XFTPClient.hs                      |  4 +-
 3 files changed, 60 insertions(+), 19 deletions(-)

diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index a6f32d481..b8ad9b2e6 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -123,7 +123,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = 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} <- asks serverStats
+      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
@@ -137,6 +137,8 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
           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
               ","
@@ -149,7 +151,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
                 weekCount files,
                 monthCount files,
                 show fileDownloads',
-                show fileDownloadAcks'
+                show fileDownloadAcks',
+                show filesCount',
+                show filesSize'
               ]
         threadDelay interval
 
@@ -248,6 +252,9 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         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
@@ -283,39 +290,55 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         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 atomically (setFilePath' st fr fPath) $> FROk
+                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 {filePath, fileInfo = FileInfo {size}} rDhKey = do
+    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
-          pure $ case LC.cbInit dhSecret cbNonce of
-            Right sbState -> (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
-            _ -> (FRErr INTERNAL, Nothing)
+          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, filePath} = do
+    deleteServerFile FileRec {senderId, fileInfo, filePath} = do
       withFileLog (`logDeleteFile` senderId)
       r <- runExceptT $ do
         path <- readTVarIO filePath
-        ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p))
+        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
@@ -325,6 +348,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       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
@@ -361,7 +386,10 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          atomically $ setFileServerStats s d
+          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
diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs
index ff70eec9d..f6e092cdf 100644
--- a/src/Simplex/FileTransfer/Server/Stats.hs
+++ b/src/Simplex/FileTransfer/Server/Stats.hs
@@ -6,6 +6,7 @@ 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)
@@ -20,7 +21,9 @@ data FileServerStats = FileServerStats
     filesDeleted :: TVar Int,
     filesDownloaded :: PeriodStats SenderId,
     fileDownloads :: TVar Int,
-    fileDownloadAcks :: TVar Int
+    fileDownloadAcks :: TVar Int,
+    filesCount :: TVar Int,
+    filesSize :: TVar Int64
   }
 
 data FileServerStatsData = FileServerStatsData
@@ -31,8 +34,11 @@ data FileServerStatsData = FileServerStatsData
     _filesDeleted :: Int,
     _filesDownloaded :: PeriodStatsData SenderId,
     _fileDownloads :: Int,
-    _fileDownloadAcks :: Int
+    _fileDownloadAcks :: Int,
+    _filesCount :: Int,
+    _filesSize :: Int64
   }
+  deriving (Show)
 
 newFileServerStats :: UTCTime -> STM FileServerStats
 newFileServerStats ts = do
@@ -44,7 +50,9 @@ newFileServerStats ts = do
   filesDownloaded <- newPeriodStats
   fileDownloads <- newTVar 0
   fileDownloadAcks <- newTVar 0
-  pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks}
+  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
@@ -56,7 +64,9 @@ getFileServerStatsData s = do
   _filesDownloaded <- getPeriodStatsData $ filesDownloaded s
   _fileDownloads <- readTVar $ fileDownloads s
   _fileDownloadAcks <- readTVar $ fileDownloadAcks s
-  pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks}
+  _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
@@ -68,6 +78,8 @@ setFileServerStats s d = do
   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} =
@@ -77,7 +89,8 @@ instance StrEncoding FileServerStatsData where
         "fileRecipients=" <> strEncode _fileRecipients,
         "filesUploaded=" <> strEncode _filesUploaded,
         "filesDeleted=" <> strEncode _filesDeleted,
-        "filesDownloaded=" <> strEncode _filesDownloaded,
+        "filesDownloaded:",
+        strEncode _filesDownloaded,
         "fileDownloads=" <> strEncode _fileDownloads,
         "fileDownloadAcks=" <> strEncode _fileDownloadAcks
       ]
@@ -87,7 +100,7 @@ instance StrEncoding FileServerStatsData where
     _fileRecipients <- "fileRecipients=" *> strP <* A.endOfLine
     _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine
     _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine
-    _filesDownloaded <- "filesDownloaded=" *> 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}
+    pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount = 0, _filesSize = 0}
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index 4fcc21c40..d6b48f6a2 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -97,8 +97,8 @@ testXFTPServerConfig =
       certificateFile = "tests/fixtures/server.crt",
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
-      serverStatsLogFile = "tests/xftp-server-stats.daily.log",
-      serverStatsBackupFile = Nothing,
+      serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
+      serverStatsBackupFile = Just "tests/tmp/xftp-server-stats.log",
       logTLSErrors = True
     }
 

From 4afb72070a99aa03c46569857e8d6824420a593b Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 28 Feb 2023 09:02:05 +0000
Subject: [PATCH 37/71] v5.0.0-beta.2


From 249bcc7bb3364341633d262aaf6424b5625c9c5d Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 28 Feb 2023 19:16:35 +0000
Subject: [PATCH 38/71] update cGet to not throw exception if returned string
 is shorter (trying to fix HTTP2), fix test (#663)

---
 src/Simplex/FileTransfer/Transport.hs     |  2 +-
 src/Simplex/Messaging/Agent/Protocol.hs   | 12 ++++++++----
 src/Simplex/Messaging/Transport.hs        | 16 ++++++++--------
 src/Simplex/Messaging/Transport/Buffer.hs |  2 ++
 tests/XFTPClient.hs                       |  7 +++++--
 tests/XFTPServerTests.hs                  |  5 +++++
 6 files changed, 29 insertions(+), 15 deletions(-)

diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index da43c2fc6..d90e54c55 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -57,7 +57,7 @@ sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go
   where
     go sbState 0 = do
-      -- TODO remove padding when HTTP2 issue is fixed
+      -- TODO padding somehow also solves timing issue in HTTP2 (?)
       let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (fileBlockSize - C.authTagSize) '#'
       send $ byteString authTag
     go sbState sz =
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index c08f86fd7..1c55a5b42 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -125,6 +125,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
@@ -1467,8 +1469,10 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
       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
diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs
index 9df1a127d..3344a8197 100644
--- a/src/Simplex/Messaging/Transport.hs
+++ b/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
@@ -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.
 --
diff --git a/src/Simplex/Messaging/Transport/Buffer.hs b/src/Simplex/Messaging/Transport/Buffer.hs
index e789eeaac..7d09d6819 100644
--- a/src/Simplex/Messaging/Transport/Buffer.hs
+++ b/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
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index d6b48f6a2..934ce3629 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -39,7 +39,7 @@ runXFTPTestN nClients test = withXFTPServer $ run nClients []
     run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
 
 withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
-withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile}
+withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
 
 withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
 withXFTPServerCfg cfg =
@@ -80,6 +80,9 @@ 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
@@ -98,7 +101,7 @@ testXFTPServerConfig =
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
-      serverStatsBackupFile = Just "tests/tmp/xftp-server-stats.log",
+      serverStatsBackupFile = Nothing,
       logTLSErrors = True
     }
 
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 3ec2a33c9..7e3d5ed16 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -235,6 +235,7 @@ testFileLog = do
     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
@@ -257,6 +258,7 @@ testFileLog = do
     -- 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
@@ -273,11 +275,14 @@ testFileLog = do
     -- 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

From 3d3eb335e8d6a02873536512045f072a3656fe97 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 1 Mar 2023 07:47:27 +0000
Subject: [PATCH 39/71] xftp: download timeout, reconnect CLI on timeouts,
 verbose logging (#664)

* xftp: download timeout, reconnect CLI on timeouts, verbose logging

* typo

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Client.hs       | 19 ++++--
 src/Simplex/FileTransfer/Client/Agent.hs | 13 +++-
 src/Simplex/FileTransfer/Client/Main.hs  | 79 ++++++++++++++++++------
 3 files changed, 84 insertions(+), 27 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 6b073b308..ff130b20e 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -31,6 +31,7 @@ import Simplex.Messaging.Client
     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.Protocol
@@ -45,8 +46,8 @@ import Simplex.Messaging.Transport.Client (TransportClientConfig)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Util (bshow, liftEitherError, whenM)
+import UnliftIO
 import UnliftIO.Directory
-import UnliftIO.IO
 
 data XFTPClient = XFTPClient
   { http2Client :: HTTP2Client,
@@ -91,6 +92,9 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfi
   http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config disconnected
   pure XFTPClient {http2Client, config}
 
+closeXFTPClient :: XFTPClient -> IO ()
+closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client
+
 xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig
 xftpHTTP2Config transportConfig XFTPClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} =
   defaultHTTP2ClientConfig
@@ -149,7 +153,7 @@ uploadXFTPChunk c spKey fId chunkSpec =
   sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
 downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
-downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
+downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do
   (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
   sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
     (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
@@ -157,10 +161,13 @@ downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
       Just chunkPart -> do
         let dhSecret = C.dh' sDhKey rpDhKey
         cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
-        -- timeout download in the same way as upload
-        withExceptT PCEResponseError $
-          receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
-            whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
+        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
 
diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs
index f52f229fc..e30956390 100644
--- a/src/Simplex/FileTransfer/Client/Agent.hs
+++ b/src/Simplex/FileTransfer/Client/Agent.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -20,7 +21,7 @@ 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 (tryError)
+import Simplex.Messaging.Util (catchAll_, tryError)
 import UnliftIO
 
 type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
@@ -114,3 +115,13 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
 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} = networkConfig $ xftpConfig config
+      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+        Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
+        _ -> pure ()
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index f1c777177..4b92a90c1 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -1,11 +1,13 @@
 {-# 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
   ( xftpClientCLI,
@@ -14,6 +16,7 @@ module Simplex.FileTransfer.Client.Main
 where
 
 import Control.Concurrent.STM (stateTVar)
+import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
@@ -30,7 +33,9 @@ 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
@@ -44,7 +49,7 @@ 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, whenM)
+import Simplex.Messaging.Util (ifM, tshow, whenM)
 import System.Exit (exitFailure)
 import System.FilePath (splitExtensions, splitFileName, (</>))
 import System.IO.Temp (getCanonicalTemporaryDirectory)
@@ -86,7 +91,8 @@ data SendOptions = SendOptions
     numRecipients :: Int,
     xftpServers :: [XFTPServerWithAuth],
     retryCount :: Int,
-    tempPath :: Maybe FilePath
+    tempPath :: Maybe FilePath,
+    verbose :: Bool
   }
   deriving (Show)
 
@@ -94,13 +100,15 @@ data ReceiveOptions = ReceiveOptions
   { fileDescription :: FilePath,
     filePath :: Maybe FilePath,
     retryCount :: Int,
-    tempPath :: Maybe FilePath
+    tempPath :: Maybe FilePath,
+    verbose :: Bool
   }
   deriving (Show)
 
 data DeleteOptions = DeleteOptions
   { fileDescription :: FilePath,
-    retryCount :: Int
+    retryCount :: Int,
+    verbose :: Bool
   }
   deriving (Show)
 
@@ -148,6 +156,7 @@ cliCommandP =
         <*> xftpServers
         <*> retryCountP
         <*> temp
+        <*> verboseP
     receiveP :: Parser ReceiveOptions
     receiveP =
       ReceiveOptions
@@ -155,11 +164,13 @@ cliCommandP =
         <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
         <*> retryCountP
         <*> temp
+        <*> verboseP
     deleteP :: Parser DeleteOptions
     deleteP =
       DeleteOptions
         <$> fileDescrArg
         <*> retryCountP
+        <*> verboseP
     infoP :: Parser InfoOptions
     infoP = InfoOptions <$> fileDescrArg
     randomP :: Parser RandomFileOptions
@@ -170,6 +181,7 @@ cliCommandP =
     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")
     xftpServers =
       option
         parseXFTPServers
@@ -208,17 +220,25 @@ data SentRecipientReplica = SentRecipientReplica
     chunkSize :: FileSize Word32
   }
 
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
 xftpClientCLI :: IO ()
 xftpClientCLI =
   getCliCommand' cliCommandP clientVersion >>= \case
-    SendFile opts -> runE $ cliSendFile opts
-    ReceiveFile opts -> runE $ cliReceiveFile opts
-    DeleteFile opts -> runE $ cliDeleteFile opts
+    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
@@ -239,7 +259,7 @@ instance Encoding FileHeader where
     pure FileHeader {fileName, fileExtra}
 
 cliSendFile :: SendOptions -> ExceptT CLIError IO ()
-cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
+cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} = do
   let (_, fileName) = splitFileName filePath
   (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFile fileName
   liftIO $ printNoNewLine "Uploading file..."
@@ -274,6 +294,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
           fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
           fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+      logInfo $ "encrypted file to " <> tshow encPath
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
       where
         encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
@@ -293,19 +314,24 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       -- 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)
-          chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
+          ch@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
-          withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
+          (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 $ printProgress "Uploaded" uploaded encSize
+          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})
@@ -384,7 +410,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       pure (fdRcvPaths, fdSndPath)
 
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
-cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} =
+cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose} =
   getFileDescription' fileDescription >>= receiveFile
   where
     receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
@@ -409,13 +435,16 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
     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
-      c <- withRetry retryCount $ getXFTPServerClient a server
       let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      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 $ printProgress "Downloaded" downloaded encSize
+      liftIO $ do
+        printProgress "Downloaded" downloaded encSize
+        when verbose $ putStrLn ""
       pure (chunkNo, chunkPath)
     downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
     decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
@@ -469,10 +498,10 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount} = do
       forM_ chunks $ deleteFileChunk a
       liftIO $ putStrLn "File deleted"
     deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
-    deleteFileChunk a FileChunk {replicas = replica : _} = do
+    deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica
-      c <- withRetry retryCount $ getXFTPServerClient a server
-      withRetry retryCount $ deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+      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 ()
@@ -541,13 +570,23 @@ uniqueCombine filePath fileName = tryCombine (0 :: Int)
           f = filePath </> (name <> suffix <> ext)
        in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f)
 
+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` \_ -> withRetry' (n - 1) a
+    withRetry' n a =
+      a `catchError` \e -> do
+        logWarn ("retrying: " <> tshow e)
+        withRetry' (n - 1) a
 
 cliRandomFile :: RandomFileOptions -> IO ()
 cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do

From 6227215c3f9f9efa0a3d8b2ab8f52cec45f0284a Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 1 Mar 2023 13:08:59 +0000
Subject: [PATCH 40/71] xftp: remove file description that cannot be used
 (#665)

* xftp: remove file description that cannot be used

* show sender file description first

* change order

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Client/Main.hs | 48 +++++++++++++++++++------
 tests/XFTPCLI.hs                        | 37 +++++++++----------
 2 files changed, 55 insertions(+), 30 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 4b92a90c1..e1f07ceb5 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -25,6 +25,7 @@ import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 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)
@@ -101,14 +102,16 @@ data ReceiveOptions = ReceiveOptions
     filePath :: Maybe FilePath,
     retryCount :: Int,
     tempPath :: Maybe FilePath,
-    verbose :: Bool
+    verbose :: Bool,
+    yes :: Bool
   }
   deriving (Show)
 
 data DeleteOptions = DeleteOptions
   { fileDescription :: FilePath,
     retryCount :: Int,
-    verbose :: Bool
+    verbose :: Bool,
+    yes :: Bool
   }
   deriving (Show)
 
@@ -165,12 +168,14 @@ cliCommandP =
         <*> retryCountP
         <*> temp
         <*> verboseP
+        <*> yesP
     deleteP :: Parser DeleteOptions
     deleteP =
       DeleteOptions
         <$> fileDescrArg
         <*> retryCountP
         <*> verboseP
+        <*> yesP
     infoP :: Parser InfoOptions
     infoP = InfoOptions <$> fileDescrArg
     randomP :: Parser RandomFileOptions
@@ -182,6 +187,7 @@ cliCommandP =
     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
@@ -272,10 +278,9 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         fdSnd' = createSndFileDescription fdSnd sentChunks
     (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd'
     printNoNewLine "File uploaded!"
-    putStrLn "\nPass file descriptions to the recipient(s):"
+    putStrLn $ "\nSender file description: " <> fdSndPath
+    putStrLn "Pass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
-    putStrLn "Sender file description:"
-    putStrLn fdSndPath
   where
     encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec], Int64)
     encryptFile fileName = do
@@ -410,7 +415,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       pure (fdRcvPaths, fdSndPath)
 
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
-cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose} =
+cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
   getFileDescription' fileDescription >>= receiveFile
   where
     receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
@@ -430,8 +435,9 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       path <- decryptFile encSize chunkPaths key nonce
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
-      liftIO $ printNoNewLine $ "File downloaded: " <> path
-      liftIO $ putStrLn "\nFile description can't be used again"
+      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
@@ -489,14 +495,16 @@ printNoNewLine s = do
   hFlush stdout
 
 cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
-cliDeleteFile DeleteOptions {fileDescription, retryCount} = do
+cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
   getFileDescription' fileDescription >>= deleteFile
   where
     deleteFile :: ValidFileDescription 'FPSender -> ExceptT CLIError IO ()
     deleteFile (ValidFileDescription FileDescription {chunks}) = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       forM_ chunks $ deleteFileChunk a
-      liftIO $ putStrLn "File deleted"
+      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
@@ -588,6 +596,26 @@ withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
         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)
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 535b3ebb9..2789bbcc5 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -45,11 +45,10 @@ testXFTPCLISendReceive = withXFTPServer $ do
   progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
-    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
                  fdRcv1,
-                 fdRcv2,
-                 "Sender file description:",
-                 fdSnd
+                 fdRcv2
                ]
   testInfoFile fdRcv1 "Recipient"
   testReceiveFile fdRcv1 "testfile" file
@@ -64,9 +63,9 @@ testXFTPCLISendReceive = withXFTPServer $ do
       xftp ["info", fd]
         `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
     testReceiveFile fd fileName file = do
-      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
       progress `shouldSatisfy` downloadProgress fileName
-      recvResult `shouldBe` ["File description can't be used again"]
+      recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLISendReceive2servers :: IO ()
@@ -81,11 +80,10 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
-    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
                  fdRcv1,
-                 fdRcv2,
-                 "Sender file description:",
-                 fdSnd
+                 fdRcv2
                ]
   testReceiveFile fdRcv1 "testfile" file
   testReceiveFile fdRcv2 "testfile_1" file
@@ -102,9 +100,9 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
           srv1 `shouldContain` testXFTPServerStr
           srv2 `shouldContain` testXFTPServerStr2
         _ -> print srvs >> error "more than 2 servers returned"
-      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
+      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
       progress `shouldSatisfy` downloadProgress fileName
-      recvResult `shouldBe` ["File description can't be used again"]
+      recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
       LB.readFile (recipientFiles </> fileName) `shouldReturn` file
 
 testXFTPCLIDelete :: IO ()
@@ -119,23 +117,22 @@ testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   progress : sendResult <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
-    `shouldBe` [ "Pass file descriptions to the recipient(s):",
+    `shouldBe` [ "Sender file description: " <> fdSnd,
+                 "Pass file descriptions to the recipient(s):",
                  fdRcv1,
-                 fdRcv2,
-                 "Sender file description:",
-                 fdSnd
+                 fdRcv2
                ]
   xftp ["del", fdRcv1]
     `shouldThrow` anyException
-  progress1 : recvResult <- xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp"]
+  progress1 : recvResult <- xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"]
   progress1 `shouldSatisfy` downloadProgress "testfile"
-  recvResult `shouldBe` ["File description can't be used again"]
+  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
-  xftp ["del", fdSnd]
-    `shouldReturn` ["File deleted"]
+  xftp ["del", fdSnd, "-y"]
+    `shouldReturn` ["File deleted!            \r", "File description " <> fdSnd <> " is deleted."]
   listDirectory xftpServerFiles >>= (`shouldBe` [])
   listDirectory xftpServerFiles2 >>= (`shouldBe` [])
   xftp ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]

From faec32dc5eae3901fcd56f1e0ff671cd0c9affdc Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 1 Mar 2023 13:50:08 +0000
Subject: [PATCH 41/71] xftp: constrain supported file size to 1gb

---
 src/Simplex/FileTransfer/Client/Main.hs | 11 ++++++++++-
 tests/XFTPCLI.hs                        |  9 +++++++--
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index e1f07ceb5..d0c68c3be 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -70,6 +70,12 @@ 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
 
@@ -267,6 +273,7 @@ instance Encoding FileHeader where
 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) <- encryptFile fileName
   liftIO $ printNoNewLine "Uploading file..."
   uploadedChunks <- newTVarIO []
@@ -284,10 +291,11 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
   where
     encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec], Int64)
     encryptFile 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
-      fileSize <- fromInteger <$> getFileSize filePath
       let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
           fileSize' = fromIntegral (B.length fileHdr) + fileSize
           chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
@@ -432,6 +440,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       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 <- decryptFile encSize chunkPaths key nonce
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 2789bbcc5..6cbbb9090 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -158,8 +158,13 @@ testPrepareChunkSizes = do
     r3 = replicate 3
 
 uploadProgress :: String -> Bool
-uploadProgress s = "Uploading file..." `isPrefixOf` s && "File uploaded!" `isInfixOf` s
+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 && ("File downloaded: " <> recipientFiles </> fileName <> "\r") `isSuffixOf` s
+  "Downloading file..." `isPrefixOf` s
+    && "Decrypting file..." `isInfixOf` s
+    && ("File downloaded: " <> recipientFiles </> fileName <> "\r") `isSuffixOf` s

From 94de01a06f13aeed152129a367e50fb7a54182b6 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 1 Mar 2023 14:36:55 +0000
Subject: [PATCH 42/71] xftp: use SHA256 digest for file chunks to reduce file
 description size (#666)

* xftp: use SHA256 digest for file chunks to reduce file description size

* enable all tests
---
 src/Simplex/FileTransfer/Client/Main.hs |  2 +-
 src/Simplex/FileTransfer/Transport.hs   |  2 +-
 src/Simplex/Messaging/Crypto/Lazy.hs    | 10 +++++++---
 tests/XFTPServerTests.hs                | 16 ++++++++--------
 4 files changed, 17 insertions(+), 13 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index d0c68c3be..3806df586 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -352,7 +352,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         getChunkInfo sndKey XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
           withFile chunkPath ReadMode $ \h -> do
             hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-            digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
+            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
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index d90e54c55..5103d94cf 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -113,5 +113,5 @@ receiveEncFile getBody = receiveFile_ . receive
 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.sha512Hash <$> LB.readFile filePath
+  digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath
   when (digest' /= chunkDigest) $ throwError DIGEST
diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs
index 1e055bdfd..db40a9fb9 100644
--- a/src/Simplex/Messaging/Crypto/Lazy.hs
+++ b/src/Simplex/Messaging/Crypto/Lazy.hs
@@ -1,14 +1,14 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Crypto.Lazy
-  ( sha512Hash,
+  ( sha256Hash,
+    sha512Hash,
     pad,
     unPad,
     sbEncrypt,
@@ -28,7 +28,7 @@ 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.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
@@ -45,6 +45,10 @@ 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)
diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs
index 7e3d5ed16..9da40ef8f 100644
--- a/tests/XFTPServerTests.hs
+++ b/tests/XFTPServerTests.hs
@@ -83,7 +83,7 @@ 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.sha512Hash <$> LB.readFile 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
@@ -108,7 +108,7 @@ 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.sha512Hash <$> LB.readFile 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
@@ -136,7 +136,7 @@ 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.sha512Hash <$> LB.readFile 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
@@ -156,7 +156,7 @@ 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.sha512Hash <$> LB.readFile testChunkPath
+  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))
@@ -167,7 +167,7 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
     (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     bytes <- liftIO $ createTestChunk testChunkPath
-    digest <- liftIO $ LC.sha512Hash <$> LB.readFile 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
@@ -190,7 +190,7 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
     (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
     bytes <- liftIO $ createTestChunk testChunkPath
-    digest <- liftIO $ LC.sha512Hash <$> LB.readFile 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
@@ -217,7 +217,7 @@ testFileLog = do
   (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
   (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
-  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
   sIdVar <- newTVarIO ""
   rIdVar1 <- newTVarIO ""
   rIdVar2 <- newTVarIO ""
@@ -295,7 +295,7 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success =
       (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
       (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
       bytes <- liftIO $ createTestChunk testChunkPath
-      digest <- liftIO $ LC.sha512Hash <$> LB.readFile 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

From e764a51fc036ae360e0cb46d28625c05288c0f14 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 1 Mar 2023 14:37:59 +0000
Subject: [PATCH 43/71] v5.0.0-beta.3


From 914240108db2f304204e6ac92bb5025a5e80acba Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 2 Mar 2023 16:00:46 +0000
Subject: [PATCH 44/71] xftp: update http2 to remove workarounds with padding
 and delay (#667)

---
 cabal.project                         | 2 +-
 src/Simplex/FileTransfer/Transport.hs | 5 +----
 2 files changed, 2 insertions(+), 5 deletions(-)

diff --git a/cabal.project b/cabal.project
index 1b036aa86..168ebc045 100644
--- a/cabal.project
+++ b/cabal.project
@@ -15,7 +15,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kazu-yamamoto/http2.git
-    tag: aa56ded3494dd4f0efb0bbcb5378879ce785a647
+    tag: c2567c30d471671302b01961d0fe1c21e1477c87
 
 source-repository-package
     type: git
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index 5103d94cf..18283367e 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -57,15 +57,12 @@ sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go
   where
     go sbState 0 = do
-      -- TODO padding somehow also solves timing issue in HTTP2 (?)
-      let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (fileBlockSize - C.authTagSize) '#'
+      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
-        -- TODO remove delay when HTTP2 issue is fixed
-        threadDelay 500
         go sbState' $ sz - fromIntegral (B.length ch)
 
 getFileChunk :: Handle -> Word32 -> IO ByteString

From 6ed4dd1515f898d204aa036f38a24f820c915394 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 3 Mar 2023 11:00:10 +0000
Subject: [PATCH 45/71] update http2 library

---
 cabal.project                         | 2 +-
 src/Simplex/FileTransfer/Transport.hs | 1 -
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/cabal.project b/cabal.project
index 168ebc045..bf2ebeaa4 100644
--- a/cabal.project
+++ b/cabal.project
@@ -15,7 +15,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kazu-yamamoto/http2.git
-    tag: c2567c30d471671302b01961d0fe1c21e1477c87
+    tag: b3b62ba36900babfde1a073c705cbccc2685f385
 
 source-repository-package
     type: git
diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs
index 18283367e..01a5757b6 100644
--- a/src/Simplex/FileTransfer/Transport.hs
+++ b/src/Simplex/FileTransfer/Transport.hs
@@ -15,7 +15,6 @@ module Simplex.FileTransfer.Transport
   )
 where
 
-import Control.Concurrent (threadDelay)
 import qualified Control.Exception as E
 import Control.Monad.Except
 import qualified Data.ByteArray as BA

From cf147397a46b23b363b68ad23469fe8dd18b5f25 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 3 Mar 2023 18:50:16 +0400
Subject: [PATCH 46/71] xftp: agent receive file (#637)

* xftp: agent receive file draft

* receiveFile more stubs, changes to types, schema

* cabal file

* comments

* xftp_server_id

* schema changes, get client, local worker/action

* agent env, save file description, adjust schema

* client stubs

* download chunk wip, store, schema, types

* remove commented code

* read file description, schema, types

* check received, decrypt

* remove pure

* todo

* add XFTP to agent client

* add user id

* agent test

* tests

* rename supervisor into agent

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 apps/smp-agent/Main.hs                        |   1 +
 simplexmq.cabal                               |  10 +
 src/Simplex/FileTransfer/Agent.hs             | 182 +++++++++++++++++
 src/Simplex/FileTransfer/Client.hs            |  38 +++-
 src/Simplex/FileTransfer/Client/Agent.hs      |   8 +-
 src/Simplex/FileTransfer/Client/Main.hs       |  29 +--
 src/Simplex/FileTransfer/Description.hs       |  14 ++
 src/Simplex/FileTransfer/Protocol.hs          |  17 +-
 src/Simplex/FileTransfer/Types.hs             | 102 ++++++++++
 src/Simplex/FileTransfer/Util.hs              |  18 ++
 src/Simplex/Messaging/Agent.hs                |   9 +
 src/Simplex/Messaging/Agent/Client.hs         | 130 +++++++++---
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |  22 +-
 src/Simplex/Messaging/Agent/Protocol.hs       |  12 ++
 src/Simplex/Messaging/Agent/Store.hs          |   4 +
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 191 +++++++++++++++++-
 .../Agent/Store/SQLite/Migrations.hs          |   4 +-
 .../SQLite/Migrations/M20230223_files.hs      |  69 +++++++
 .../Store/SQLite/Migrations/agent_schema.sql  |  56 +++++
 src/Simplex/Messaging/Client.hs               |   6 +-
 src/Simplex/Messaging/Crypto.hs               |   8 +
 tests/SMPAgentClient.hs                       |   7 +-
 tests/Test.hs                                 |   2 +
 tests/XFTPAgent.hs                            |  59 ++++++
 tests/XFTPCLI.hs                              |  37 ++--
 tests/XFTPClient.hs                           |   2 +-
 26 files changed, 942 insertions(+), 95 deletions(-)
 create mode 100644 src/Simplex/FileTransfer/Agent.hs
 create mode 100644 src/Simplex/FileTransfer/Types.hs
 create mode 100644 src/Simplex/FileTransfer/Util.hs
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
 create mode 100644 tests/XFTPAgent.hs

diff --git a/apps/smp-agent/Main.hs b/apps/smp-agent/Main.hs
index 0c51b5619..ce73ccbea 100644
--- a/apps/smp-agent/Main.hs
+++ b/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
     }
 
diff --git a/simplexmq.cabal b/simplexmq.cabal
index f88530698..87a5fe16c 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -35,6 +35,7 @@ flag swift
 library
   exposed-modules:
       Simplex.FileTransfer
+      Simplex.FileTransfer.Agent
       Simplex.FileTransfer.Client
       Simplex.FileTransfer.Client.Agent
       Simplex.FileTransfer.Client.Main
@@ -47,6 +48,8 @@ library
       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
@@ -72,6 +75,7 @@ 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.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
@@ -224,6 +228,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.*
@@ -287,6 +292,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.*
@@ -350,6 +356,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.*
@@ -477,6 +484,7 @@ executable xftp-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.*
@@ -517,6 +525,7 @@ test-suite simplexmq-test
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPAgent
       XFTPCLI
       XFTPClient
       XFTPServerTests
@@ -568,6 +577,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.*
diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
new file mode 100644
index 000000000..a989c20fe
--- /dev/null
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Agent
+  ( receiveFile,
+  )
+where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Types
+import Simplex.FileTransfer.Util (uniqueCombine)
+import Simplex.Messaging.Agent.Client
+import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Protocol (ACommand (FRCVD), AParty (..), AgentErrorType (INTERNAL))
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store
+import Simplex.Messaging.Agent.Store.SQLite
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Protocol (XFTPServer)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (whenM)
+import UnliftIO
+import UnliftIO.Directory
+import qualified UnliftIO.Exception as E
+
+receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FPRecipient -> FilePath -> m Int64
+receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpPath = do
+  encPath <- uniqueCombine xftpPath "xftp.encrypted"
+  createDirectory encPath
+  fId <- withStore' c $ \db -> createRcvFile db userId fd xftpPath encPath
+  forM_ chunks downloadChunk
+  pure fId
+  where
+    downloadChunk :: AgentMonad m => FileChunk -> m ()
+    downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
+      addWorker c (Just server)
+    downloadChunk _ = throwError $ INTERNAL "no replicas"
+
+addWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addWorker 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
+    runXftpOperation :: m ()
+    runXftpOperation = do
+      nextChunk <- withStore' c (`getNextRcvChunkToDownload` srv)
+      case nextChunk of
+        Nothing -> noWorkToDo
+        Just fc@RcvFileChunk {nextDelay} -> do
+          ri <- asks $ reconnectInterval . config
+          let ri' = maybe ri (\d -> ri {initialInterval = d}) nextDelay
+          withRetryInterval ri' $ \loop ->
+            downloadFileChunk fc
+              `catchError` \e -> do
+                liftIO $ print e
+                -- TODO don't loop on permanent errors
+                -- TODO increase replica retries count
+                -- TODO update nextDelay (modify withRetryInterval to expose current delay)
+                loop
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    downloadFileChunk :: RcvFileChunk -> m ()
+    downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, replicas = 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
+        fd <- ExceptT $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId rcvFileId chunkPath
+        let fileReceived = allChunksReceived fd
+        when fileReceived $
+          liftIO $ updateRcvFileStatus db rcvFileId RFSReceived
+        pure fileReceived
+      -- check if chunk is downloaded and not acknowledged via flag acknowledged?
+      -- or just catch and ignore error on acknowledgement? (and remove flag)
+      -- agentXFTPAckChunk c replicaKey (unChunkReplicaId replicaId) `catchError` \_ -> pure ()
+      when fileReceived $ addWorker c Nothing
+      where
+        allChunksReceived :: RcvFile -> Bool
+        allChunksReceived RcvFile {chunks} =
+          all (\RcvFileChunk {replicas} -> any received replicas) chunks
+    downloadFileChunk _ = throwError $ INTERNAL "no replica"
+
+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 fd -> do
+          ri <- asks $ reconnectInterval . config
+          withRetryInterval ri $ \loop ->
+            decryptFile fd
+              `catchError` \e -> do
+                liftIO $ print e
+                -- TODO don't loop on permanent errors
+                -- TODO fixed number of retries instead of exponential backoff?
+                loop
+    noWorkToDo = void . atomically $ tryTakeTMVar doWork
+    decryptFile :: RcvFile -> m ()
+    decryptFile RcvFile {rcvFileId, key, nonce, tmpPath, saveDir, chunks} = do
+      -- TODO remove tmpPath if exists
+      withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
+      chunkPaths <- getChunkPaths chunks
+      encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      path <- decrypt encSize chunkPaths
+      whenM (doesPathExist tmpPath) $ removeDirectoryRecursive tmpPath
+      withStore' c $ \db -> updateRcvFileComplete db rcvFileId path
+      notify $ FRCVD rcvFileId path
+      where
+        notify :: ACommand 'Agent -> m ()
+        notify cmd = atomically $ writeTBQueue subQ ("", "", 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"
+        decrypt :: Int64 -> [FilePath] -> m FilePath
+        decrypt encSize chunkPaths = do
+          lazyChunks <- readChunks chunkPaths
+          (authOk, f) <- liftEither . first cryptoError $ LC.sbDecryptTailTag key nonce (encSize - authTagSize) lazyChunks
+          let (fileHdr, f') = LB.splitAt 1024 f
+          -- withFile encPath ReadMode $ \r -> do
+          --   fileHdr <- liftIO $ B.hGet r 1024
+          case A.parse smpP $ LB.toStrict fileHdr of
+            -- TODO XFTP errors
+            A.Fail _ _ e -> throwError $ INTERNAL $ "Invalid file header: " <> e
+            A.Partial _ -> throwError $ INTERNAL "Invalid file header"
+            A.Done rest FileHeader {fileName} -> do
+              -- TODO touch file in agent bracket
+              path <- uniqueCombine saveDir fileName
+              liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
+              unless authOk $ do
+                removeFile path
+                throwError $ INTERNAL "Error decrypting file: incorrect auth tag"
+              pure path
+        readChunks :: [FilePath] -> m LB.ByteString
+        readChunks =
+          foldM
+            ( \s path -> do
+                chunk <- liftIO $ LB.readFile path
+                pure $ s <> chunk
+            )
+            LB.empty
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index ff130b20e..124f433b5 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -16,6 +16,7 @@ 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
@@ -34,6 +35,7 @@ import Simplex.Messaging.Client
 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 (..),
@@ -42,7 +44,7 @@ import Simplex.Messaging.Protocol
     SenderId,
   )
 import Simplex.Messaging.Transport (supportedParameters)
-import Simplex.Messaging.Transport.Client (TransportClientConfig)
+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)
@@ -51,11 +53,12 @@ import UnliftIO.Directory
 
 data XFTPClient = XFTPClient
   { http2Client :: HTTP2Client,
+    transportSession :: TransportSession FileResponse,
     config :: XFTPClientConfig
   }
 
 data XFTPClientConfig = XFTPClientConfig
-  { networkConfig :: NetworkConfig,
+  { xftpNetworkConfig :: NetworkConfig,
     uploadTimeoutPerMb :: Int
   }
 
@@ -77,26 +80,41 @@ type XFTPClientError = ProtocolClientError XFTPErrorType
 defaultXFTPClientConfig :: XFTPClientConfig
 defaultXFTPClientConfig =
   XFTPClientConfig
-    { networkConfig = defaultNetworkConfig,
+    { xftpNetworkConfig = defaultNetworkConfig,
       uploadTimeoutPerMb = 10000000 -- 10 seconds
     }
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfig} disconnected = runExceptT $ do
-  let tcConfig = transportClientConfig networkConfig
+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 networkConfig host
+  useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
+  clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
-  http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config disconnected
-  pure XFTPClient {http2Client, config}
+      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 {networkConfig = NetworkConfig {tcpConnectTimeout}} =
+xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} =
   defaultHTTP2ClientConfig
     { bodyHeadSize = xftpBlockSize,
       suportedTLSParams = supportedParameters,
diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs
index e30956390..56ec9f0f6 100644
--- a/src/Simplex/FileTransfer/Client/Agent.hs
+++ b/src/Simplex/FileTransfer/Client/Agent.hs
@@ -68,8 +68,8 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
         first (XFTPClientAgentError srv)
           <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: XFTPClient -> IO ()
+    clientDisconnected _ = do
       atomically $ TM.delete srv xftpClients
       logInfo $ "disconnected from " <> showServer srv
 
@@ -84,7 +84,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
 
     waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
     waitForXFTPClient clientVar = do
-      let XFTPClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
+      let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
       client_ <- tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
       liftEither $ case client_ of
         Just (Right c) -> Right c
@@ -121,7 +121,7 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
   atomically (TM.lookupDelete srv xftpClients) >>= mapM_ closeClient
   where
     closeClient cVar = do
-      let NetworkConfig {tcpConnectTimeout} = networkConfig $ xftpConfig config
+      let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
       tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
         _ -> pure ()
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 3806df586..e0f113ba5 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -43,6 +43,8 @@ import Simplex.FileTransfer.Client.Agent
 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
@@ -52,7 +54,7 @@ import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivat
 import Simplex.Messaging.Server.CLI (getCliCommand')
 import Simplex.Messaging.Util (ifM, tshow, whenM)
 import System.Exit (exitFailure)
-import System.FilePath (splitExtensions, splitFileName, (</>))
+import System.FilePath (splitFileName, (</>))
 import System.IO.Temp (getCanonicalTemporaryDirectory)
 import System.Random (StdGen, newStdGen, randomR)
 import UnliftIO
@@ -79,9 +81,6 @@ maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize
 fileSizeLen :: Int64
 fileSizeLen = 8
 
-authTagSize :: Int64
-authTagSize = fromIntegral C.authTagSize
-
 newtype CLIError = CLIError String
   deriving (Eq, Show, Exception)
 
@@ -257,19 +256,6 @@ runE a =
     Left (CLIError e) -> putStrLn e >> exitFailure
     _ -> pure ()
 
--- 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}
-
 cliSendFile :: SendOptions -> ExceptT CLIError IO ()
 cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} = do
   let (_, fileName) = splitFileName filePath
@@ -578,15 +564,6 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c
 getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
 getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path
 
-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)
-
 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
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index cee74ff9a..ff3d7e144 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -39,6 +39,8 @@ 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 Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -96,6 +98,10 @@ 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,
@@ -125,6 +131,10 @@ 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,
@@ -226,6 +236,10 @@ gb n = 1024 * mb n
 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)
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 954b3e81b..8f793114f 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -13,6 +13,7 @@
 
 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
@@ -25,6 +26,7 @@ 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
@@ -55,8 +57,9 @@ import Simplex.Messaging.Protocol
     _smpP,
   )
 import Simplex.Messaging.Transport (SessionId, TransportError (..))
-import Simplex.Messaging.Util ((<$?>))
+import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.Version
+import Test.QuickCheck (Arbitrary (..))
 
 currentXFTPVersion :: Version
 currentXFTPVersion = 1
@@ -354,6 +357,18 @@ data XFTPErrorType
     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"
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
new file mode 100644
index 000000000..dc6bd8f84
--- /dev/null
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -0,0 +1,102 @@
+{-# 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.Description
+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 RcvFileId = Int64
+
+data RcvFile = RcvFile
+  { userId :: Int64,
+    rcvFileId :: RcvFileId,
+    size :: FileSize Int64,
+    digest :: FileDigest,
+    key :: C.SbKey,
+    nonce :: C.CbNonce,
+    chunkSize :: FileSize Word32,
+    chunks :: [RcvFileChunk],
+    tmpPath :: FilePath,
+    saveDir :: FilePath,
+    savePath :: Maybe FilePath,
+    status :: RcvFileStatus,
+    status :: RcvFileStatus
+  }
+  deriving (Eq, Show)
+
+-- TODO add error status?
+data RcvFileStatus
+  = RFSReceiving
+  | RFSReceived
+  | RFSDecrypting
+  | RFSComplete
+  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
+    _ -> Nothing
+  textEncode = \case
+    RFSReceiving -> "receiving"
+    RFSReceived -> "received"
+    RFSDecrypting -> "decrypting"
+    RFSComplete -> "complete"
+
+data RcvFileChunk = RcvFileChunk
+  { userId :: Int64,
+    rcvFileId :: RcvFileId,
+    rcvChunkId :: Int64,
+    chunkNo :: Int,
+    chunkSize :: FileSize Word32,
+    digest :: FileDigest,
+    replicas :: [RcvFileChunkReplica],
+    fileTmpPath :: FilePath,
+    chunkTmpPath :: Maybe FilePath,
+    nextDelay :: Maybe Int
+  }
+  deriving (Eq, Show)
+
+data RcvFileChunkReplica = RcvFileChunkReplica
+  { rcvChunkReplicaId :: Int64,
+    server :: XFTPServer,
+    replicaId :: ChunkReplicaId,
+    replicaKey :: C.APrivateSignKey,
+    received :: Bool,
+    acknowledged :: Bool,
+    retries :: Int
+  }
+  deriving (Eq, Show)
diff --git a/src/Simplex/FileTransfer/Util.hs b/src/Simplex/FileTransfer/Util.hs
new file mode 100644
index 000000000..f8ac3d1f8
--- /dev/null
+++ b/src/Simplex/FileTransfer/Util.hs
@@ -0,0 +1,18 @@
+module Simplex.FileTransfer.Util
+  ( uniqueCombine,
+  )
+where
+
+import Simplex.Messaging.Util (ifM)
+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)
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 1a0de3be0..80749ac6d 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -80,6 +80,7 @@ module Simplex.Messaging.Agent
     getNtfToken,
     getNtfTokenData,
     toggleConnectionNtfs,
+    xftpReceiveFile,
     activateAgent,
     suspendAgent,
     execAgentStoreSQL,
@@ -113,6 +114,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 (receiveFile)
+import Simplex.FileTransfer.Description (ValidFileDescription)
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Types (RcvFileId)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock (withLock)
@@ -322,6 +327,10 @@ 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 'FPRecipient -> FilePath -> m RcvFileId
+xftpReceiveFile c = withAgentEnv c .:. receiveFile c
+
 -- | Activate operations
 activateAgent :: AgentErrorMonad m => AgentClient -> m ()
 activateAgent c = withAgentEnv c $ activateAgent' c
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index dbc22684d..95eb48d3a 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -15,6 +15,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
@@ -48,6 +49,7 @@ module Simplex.Messaging.Agent.Client
     agentNtfCreateSubscription,
     agentNtfCheckSubscription,
     agentNtfDeleteSubscription,
+    agentXFTPDownloadChunk,
     agentCbEncrypt,
     agentCbDecrypt,
     cryptoError,
@@ -108,10 +110,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 +160,7 @@ import Simplex.Messaging.Protocol
     RcvNtfPublicDhKey,
     SMPMsgMeta (..),
     SndPublicVerifyKey,
+    XFTPServerWithAuth,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
@@ -163,16 +173,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 +196,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 +262,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 +272,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 +308,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
         smpClients,
         ntfServers,
         ntfClients,
+        xftpServers,
+        xftpClients,
         useNetworkConfig,
         subscrConns,
         activeSubs,
@@ -320,17 +340,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
@@ -420,6 +464,27 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
       atomically $ writeTBQueue (subQ c) ("", "", 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) ("", "", 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))
 getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup tSess clients
   where
@@ -429,7 +494,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,17 +505,17 @@ 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
@@ -475,8 +540,8 @@ 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) -> Client msg -> ACommand 'Agent
+hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
 
 getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
 getClientConfig AgentClient {useNetworkConfig} cfgSel = do
@@ -519,7 +584,7 @@ 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
@@ -527,7 +592,7 @@ closeProtocolServerClients c clientsSel =
     closeClient cVar = do
       NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
       tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
-        Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
+        Just (Right client) -> closeProtocolServerClient client `catchAll_` pure ()
         _ -> pure ()
 
 cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
@@ -542,29 +607,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 +645,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_
 
@@ -912,6 +988,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
@@ -1041,7 +1121,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 ()
@@ -1051,8 +1131,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}
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index 0bba24180..de256d317 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -24,6 +24,7 @@ module Simplex.Messaging.Agent.Env.SQLite
     createAgentStore,
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
+    XFTPAgent (..),
   )
 where
 
@@ -37,6 +38,7 @@ import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
+import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store (UserId)
@@ -47,7 +49,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 (..))
@@ -63,6 +65,7 @@ type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorTy
 data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty SMPServerWithAuth),
     ntf :: [NtfServer],
+    xftp :: Map UserId (NonEmpty XFTPServerWithAuth),
     netCfg :: NetworkConfig
   }
 
@@ -84,6 +87,7 @@ data AgentConfig = AgentConfig
     yesToMigrations :: Bool,
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
+    xftpCfg :: XFTPClientConfig,
     reconnectInterval :: RetryInterval,
     messageRetryInterval :: RetryInterval2,
     messageTimeout :: NominalDiffTime,
@@ -144,6 +148,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 +178,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 +191,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 +214,12 @@ newNtfSubSupervisor qSize = do
   ntfWorkers <- TM.empty
   ntfSMPWorkers <- TM.empty
   pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
+
+data XFTPAgent = XFTPAgent
+  { xftpWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ())
+  }
+
+newXFTPAgent :: STM XFTPAgent
+newXFTPAgent = do
+  xftpWorkers <- TM.empty
+  pure XFTPAgent {xftpWorkers}
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 1c55a5b42..f1e7cec1d 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -155,6 +155,8 @@ import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
+import Simplex.FileTransfer.Protocol (XFTPErrorType)
+import Simplex.FileTransfer.Types (RcvFileId)
 import Simplex.Messaging.Agent.QueryString
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
@@ -282,6 +284,7 @@ data ACommand (p :: AParty) where
   OK :: ACommand Agent
   ERR :: AgentErrorType -> ACommand Agent
   SUSPENDED :: ACommand Agent
+  FRCVD :: RcvFileId -> FilePath -> ACommand Agent
 
 deriving instance Eq (ACommand p)
 
@@ -324,6 +327,7 @@ data ACommandTag (p :: AParty) where
   OK_ :: ACommandTag Agent
   ERR_ :: ACommandTag Agent
   SUSPENDED_ :: ACommandTag Agent
+  FRCVD_ :: ACommandTag Agent
 
 deriving instance Eq (ACommandTag p)
 
@@ -365,6 +369,7 @@ aCommandTag = \case
   OK -> OK_
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
+  FRCVD {} -> FRCVD_
 
 data QueueDirection = QDRcv | QDSnd
   deriving (Eq, Show)
@@ -1072,6 +1077,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
@@ -1166,6 +1173,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)
@@ -1179,6 +1187,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
@@ -1282,6 +1291,7 @@ instance APartyI p => StrEncoding (ACommandTag p) where
     OK_ -> "OK"
     ERR_ -> "ERR"
     SUSPENDED_ -> "SUSPENDED"
+    FRCVD_ -> "FRCVD"
   strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP
 
 checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p)
@@ -1332,6 +1342,7 @@ commandP binaryP =
           OK_ -> pure OK
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
+          FRCVD_ -> s (FRCVD <$> A.decimal <* A.space <*> strP)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
@@ -1385,6 +1396,7 @@ serializeCommand = \case
   ERR e -> s (ERR_, e)
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
+  FRCVD fId fPath -> s (FRCVD_, Str $ bshow fId, fPath)
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index adcf70224..42c69398a 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -535,4 +535,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)
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 85b5d3fc7..8eae34807 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -123,6 +123,16 @@ module Simplex.Messaging.Agent.Store.SQLite
     getActiveNtfToken,
     getNtfRcvQueue,
     setConnectionNtfs,
+    -- File transfer
+    createRcvFile,
+    getRcvFile,
+    updateRcvFileChunkReceived,
+    updateRcvFileStatus,
+    updateRcvFileComplete,
+    updateRcvFileChunkReplicaRetries,
+    getNextRcvChunkToDownload,
+    getNextRcvFileToDecrypt,
+    getUnreceivedRcvFiles,
 
     -- * utilities
     withConnection,
@@ -155,6 +165,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 +173,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 +187,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 +1717,178 @@ 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 -> UserId -> FileDescription 'FPRecipient -> FilePath -> FilePath -> IO RcvFileId
+createRcvFile db userId fd@FileDescription {chunks} saveDir tmpPath = do
+  rcvFileId <- insertRcvFile fd
+  forM_ chunks $ \fc@FileChunk {replicas} -> do
+    chunkId <- insertChunk fc rcvFileId
+    forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertReplica rno replica chunkId
+  pure rcvFileId
+  where
+    insertRcvFile FileDescription {size, digest, key, nonce, chunkSize} = do
+      DB.execute
+        db
+        "INSERT INTO rcv_files (user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, status) VALUES (?,?,?,?,?,?,?,?,?)"
+        (userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, RFSReceiving)
+      insertedRowId db
+    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)
+
+getRcvFile :: DB.Connection -> RcvFileId -> IO (Either StoreError RcvFile)
+getRcvFile db rcvFileId = runExceptT $ do
+  fd@RcvFile {userId, tmpPath} <- ExceptT getFile
+  chunks <- liftIO $ getChunks userId tmpPath
+  pure (fd {chunks} :: RcvFile)
+  where
+    getFile :: IO (Either StoreError RcvFile)
+    getFile = do
+      firstRow toFile SEFileNotFound $
+        DB.query
+          db
+          [sql|
+            SELECT user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, save_path, status
+            FROM rcv_files
+            WHERE rcv_file_id = ?
+          |]
+          (Only rcvFileId)
+      where
+        toFile :: (UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile
+        toFile (userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status) =
+          RcvFile {userId, rcvFileId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status, chunks = []}
+    getChunks :: UserId -> FilePath -> IO [RcvFileChunk]
+    getChunks userId fileTmpPath = do
+      chunks <-
+        map toChunk
+          <$> DB.query
+            db
+            [sql|
+              SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path, next_delay
+              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, Maybe Int) -> RcvFileChunk
+        toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath, nextDelay) =
+          RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, nextDelay, 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.acknowledged, 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, Bool, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
+        toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, acknowledged, retries, host, port, keyHash) =
+          let server = XFTPServer host port keyHash
+           in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, acknowledged, retries}
+
+updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> RcvFileId -> 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 -> RcvFileId -> 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)
+
+updateRcvFileComplete :: DB.Connection -> RcvFileId -> FilePath -> IO ()
+updateRcvFileComplete db rcvFileId savePath = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_files SET save_path = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (savePath, RFSComplete, updatedAt, rcvFileId)
+
+updateRcvFileChunkReplicaRetries :: DB.Connection -> Int64 -> IO ()
+updateRcvFileChunkReplicaRetries _db _replicaId = do
+  -- update rcv_file_chunk_replicas
+  undefined
+
+getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> IO (Maybe RcvFileChunk)
+getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
+  maybeFirstRow toChunk $
+    DB.query
+      db
+      [sql|
+        SELECT
+          f.user_id, f.rcv_file_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, c.next_delay,
+          r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.acknowledged, 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
+        ORDER BY r.created_at ASC
+        LIMIT 1
+      |]
+      (host, port, keyHash)
+  where
+    toChunk :: ((UserId, RcvFileId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Bool, Int)) -> RcvFileChunk
+    toChunk ((userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, nextDelay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, acknowledged, retries)) =
+      RcvFileChunk
+        { userId,
+          rcvFileId,
+          rcvChunkId,
+          chunkNo,
+          chunkSize,
+          digest,
+          fileTmpPath,
+          chunkTmpPath,
+          nextDelay,
+          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, acknowledged, retries}]
+        }
+
+getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
+getNextRcvFileToDecrypt db = do
+  fileId_ :: Maybe RcvFileId <-
+    maybeFirstRow fromOnly $
+      DB.query db "SELECT rcv_file_id FROM rcv_files WHERE status = ? ORDER BY created_at ASC LIMIT 1" (Only RFSReceived)
+  case fileId_ of
+    Nothing -> pure Nothing
+    Just fileId -> eitherToMaybe <$> getRcvFile db fileId
+
+getUnreceivedRcvFiles :: DB.Connection -> IO [RcvFile]
+getUnreceivedRcvFiles _db = do
+  -- get unique file ids from rcv_files where status /= complete
+  -- getRcvFile for each file id
+  undefined
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
index d896da044..7cdc153a4 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+++ b/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
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
new file mode 100644
index 000000000..11cd45801
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -0,0 +1,69 @@
+{-# 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 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,
+  tmp_path TEXT NOT NULL,
+  save_dir TEXT NOT NULL,
+  save_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_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,
+  next_delay INTEGER,
+  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,
+  acknowledged 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_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);
+|]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 540329a57..13aa097a6 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -283,3 +283,59 @@ 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 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,
+  tmp_path TEXT NOT NULL,
+  save_dir TEXT NOT NULL,
+  save_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_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,
+  next_delay INTEGER,
+  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,
+  acknowledged 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_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
+);
diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index b4d633860..7df7cf97d 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -31,7 +31,7 @@ module Simplex.Messaging.Client
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
-    clientServer,
+    protocolClientServer,
     transportHost',
     transportSession',
 
@@ -254,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
 
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 10ad2b047..dcc8d595a 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -1032,6 +1032,10 @@ instance ToJSON CbNonce where
 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
@@ -1072,6 +1076,10 @@ instance ToJSON SbKey where
 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
   | B.length s == 32 = Right $ SecretBoxKey s
diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs
index b21554891..2687594d7 100644
--- a/tests/SMPAgentClient.hs
+++ b/tests/SMPAgentClient.hs
@@ -32,6 +32,7 @@ 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, XFTPServer)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Test.Hspec
@@ -173,11 +174,15 @@ testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:50
 testSMPServer2 :: SMPServer
 testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
 
+testXFTPServer :: XFTPServer
+testXFTPServer = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"
+
 initAgentServers :: InitialAgentServers
 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 +213,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
diff --git a/tests/Test.hs b/tests/Test.hs
index 2643674f6..d76357be4 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -16,6 +16,7 @@ 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)
 
@@ -46,4 +47,5 @@ main = do
           describe "XFTP server" xftpServerTests
           describe "XFTP file description" fileDescriptionTests
           describe "XFTP CLI" xftpCLITests
+          describe "XFTP agent" xftpAgentTests
         describe "Server CLIs" cliTests
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
new file mode 100644
index 000000000..2bca61a17
--- /dev/null
+++ b/tests/XFTPAgent.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module XFTPAgent where
+
+import AgentTests.FunctionalAPITests (get, runRight_)
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import qualified Data.ByteString as LB
+import SMPAgentClient (agentCfg, initAgentServers)
+import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
+import Simplex.Messaging.Agent (getSMPAgentClient, xftpReceiveFile)
+import Simplex.Messaging.Agent.Protocol (ACommand (FRCVD), AgentErrorType (..))
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import System.Directory (getFileSize)
+import System.FilePath ((</>))
+import Test.Hspec
+import XFTPCLI
+import XFTPClient
+
+xftpAgentTests :: Spec
+xftpAgentTests = around_ testBracket . describe "Functional API" $ do
+  it "should receive file" testXFTPAgentReceive
+
+testXFTPAgentReceive :: IO ()
+testXFTPAgentReceive = withXFTPServer $ do
+  -- send file using CLI
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.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 'FPRecipient <- getFileDescription fdRcv
+    fId <- xftpReceiveFile rcp 1 fd recipientFiles
+    ("", "", FRCVD fId' path) <- get rcp
+    liftIO $ do
+      fId' `shouldBe` fId
+      LB.readFile path `shouldReturn` file
+  where
+    getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FPRecipient)
+    getFileDescription path = do
+      fd :: AFileDescription <- ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> LB.readFile path
+      vfd <- liftEither . first INTERNAL $ validateFileDescription fd
+      case vfd of
+        AVFD fd' -> either (throwError . INTERNAL) pure $ checkParty fd'
diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs
index 6cbbb9090..14c62aea5 100644
--- a/tests/XFTPCLI.hs
+++ b/tests/XFTPCLI.hs
@@ -33,16 +33,19 @@ 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"
-  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  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 <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
     `shouldBe` [ "Sender file description: " <> fdSnd,
@@ -55,15 +58,14 @@ testXFTPCLISendReceive = withXFTPServer $ do
   testInfoFile fdRcv2 "Recipient"
   testReceiveFile fdRcv2 "testfile_1" file
   testInfoFile fdSnd "Sender"
-  xftp ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
+  xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
     `shouldThrow` anyException
   where
-    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testInfoFile fd party = do
-      xftp ["info", fd]
+      xftpCLI ["info", fd]
         `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
     testReceiveFile fd fileName file = do
-      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
+      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
@@ -71,13 +73,13 @@ testXFTPCLISendReceive = withXFTPServer $ do
 testXFTPCLISendReceive2servers :: IO ()
 testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  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 <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
     `shouldBe` [ "Sender file description: " <> fdSnd,
@@ -88,9 +90,8 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
   testReceiveFile fdRcv1 "testfile" file
   testReceiveFile fdRcv2 "testfile_1" file
   where
-    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
     testReceiveFile fd fileName file = do
-      partyStr : sizeStr : srvStr : srvs <- xftp ["info", fd]
+      partyStr : sizeStr : srvStr : srvs <- xftpCLI ["info", fd]
       partyStr `shouldContain` "Recipient file description"
       sizeStr `shouldBe` "File download size: 18mb"
       srvStr `shouldBe` "File server(s):"
@@ -100,7 +101,7 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
           srv1 `shouldContain` testXFTPServerStr
           srv2 `shouldContain` testXFTPServerStr2
         _ -> print srvs >> error "more than 2 servers returned"
-      progress : recvResult <- xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
+      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
@@ -108,13 +109,13 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
 testXFTPCLIDelete :: IO ()
 testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
   let filePath = senderFiles </> "testfile"
-  xftp ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  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 <- xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
+  progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
   progress `shouldSatisfy` uploadProgress
   sendResult
     `shouldBe` [ "Sender file description: " <> fdSnd,
@@ -122,23 +123,21 @@ testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
                  fdRcv1,
                  fdRcv2
                ]
-  xftp ["del", fdRcv1]
+  xftpCLI ["del", fdRcv1]
     `shouldThrow` anyException
-  progress1 : recvResult <- xftp ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"]
+  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
-  xftp ["del", fdSnd, "-y"]
+  xftpCLI ["del", fdSnd, "-y"]
     `shouldReturn` ["File deleted!            \r", "File description " <> fdSnd <> " is deleted."]
   listDirectory xftpServerFiles >>= (`shouldBe` [])
   listDirectory xftpServerFiles2 >>= (`shouldBe` [])
-  xftp ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
+  xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
     `shouldThrow` anyException
-  where
-    xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
 
 testPrepareChunkSizes :: IO ()
 testPrepareChunkSizes = do
diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs
index 934ce3629..5bfcadf47 100644
--- a/tests/XFTPClient.hs
+++ b/tests/XFTPClient.hs
@@ -110,6 +110,6 @@ testXFTPClientConfig = defaultXFTPClientConfig
 
 testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
 testXFTPClient client =
-  getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (pure ()) >>= \case
+  getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case
     Right c -> client c
     Left e -> error $ show e

From a0c86158d92f35ea375c0cdbaf546e2cf00e7717 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 3 Mar 2023 20:39:15 +0400
Subject: [PATCH 47/71] xftp agent: update chunk delay (#671)

---
 src/Simplex/FileTransfer/Agent.hs              | 16 +++++++---------
 src/Simplex/FileTransfer/Client/Agent.hs       |  2 +-
 src/Simplex/FileTransfer/Types.hs              |  2 +-
 src/Simplex/Messaging/Agent/Store/SQLite.hs    | 18 ++++++++++++------
 .../Store/SQLite/Migrations/M20230223_files.hs |  2 +-
 .../Store/SQLite/Migrations/agent_schema.sql   |  2 +-
 6 files changed, 23 insertions(+), 19 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index a989c20fe..3e76bf579 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -78,16 +78,15 @@ runXFTPWorker c srv doWork = do
       nextChunk <- withStore' c (`getNextRcvChunkToDownload` srv)
       case nextChunk of
         Nothing -> noWorkToDo
-        Just fc@RcvFileChunk {nextDelay} -> do
+        Just fc@RcvFileChunk {rcvChunkId, delay} -> do
           ri <- asks $ reconnectInterval . config
-          let ri' = maybe ri (\d -> ri {initialInterval = d}) nextDelay
-          withRetryInterval ri' $ \loop ->
+          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
+          withRetryInterval ri' $ \delay' loop ->
             downloadFileChunk fc
-              `catchError` \e -> do
-                liftIO $ print e
+              `catchError` \_ -> do
+                withStore' c $ \db -> updateRcvFileChunkDelay db rcvChunkId delay'
                 -- TODO don't loop on permanent errors
                 -- TODO increase replica retries count
-                -- TODO update nextDelay (modify withRetryInterval to expose current delay)
                 loop
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     downloadFileChunk :: RcvFileChunk -> m ()
@@ -125,10 +124,9 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
         Nothing -> noWorkToDo
         Just fd -> do
           ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
+          withRetryInterval ri $ \_ loop ->
             decryptFile fd
-              `catchError` \e -> do
-                liftIO $ print e
+              `catchError` \_ -> do
                 -- TODO don't loop on permanent errors
                 -- TODO fixed number of retries instead of exponential backoff?
                 loop
diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs
index 56ec9f0f6..00ee89404 100644
--- a/src/Simplex/FileTransfer/Client/Agent.hs
+++ b/src/Simplex/FileTransfer/Client/Agent.hs
@@ -110,7 +110,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
               throwError e
         tryConnectAsync :: ME ()
         tryConnectAsync = void . async $ do
-          withRetryInterval (reconnectInterval config) $ void . tryConnectClient
+          withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop
 
 showServer :: XFTPServer -> Text
 showServer ProtocolServer {host, port} =
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index dc6bd8f84..64f5f0be7 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -86,7 +86,7 @@ data RcvFileChunk = RcvFileChunk
     replicas :: [RcvFileChunkReplica],
     fileTmpPath :: FilePath,
     chunkTmpPath :: Maybe FilePath,
-    nextDelay :: Maybe Int
+    delay :: Maybe Int
   }
   deriving (Eq, Show)
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 8eae34807..c3db99806 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -126,6 +126,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- File transfer
     createRcvFile,
     getRcvFile,
+    updateRcvFileChunkDelay,
     updateRcvFileChunkReceived,
     updateRcvFileStatus,
     updateRcvFileComplete,
@@ -1789,7 +1790,7 @@ getRcvFile db rcvFileId = runExceptT $ do
           <$> DB.query
             db
             [sql|
-              SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path, next_delay
+              SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path, delay
               FROM rcv_file_chunks
               WHERE rcv_file_id = ?
             |]
@@ -1799,8 +1800,8 @@ getRcvFile db rcvFileId = runExceptT $ do
         pure (chunk {replicas = replicas'} :: RcvFileChunk)
       where
         toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath, Maybe Int) -> RcvFileChunk
-        toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath, nextDelay) =
-          RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, nextDelay, replicas = []}
+        toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath, delay) =
+          RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay, replicas = []}
     getChunkReplicas :: Int64 -> IO [RcvFileChunkReplica]
     getChunkReplicas chunkId = do
       map toReplica
@@ -1821,6 +1822,11 @@ getRcvFile db rcvFileId = runExceptT $ do
           let server = XFTPServer host port keyHash
            in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, acknowledged, retries}
 
+updateRcvFileChunkDelay :: DB.Connection -> Int64 -> Int -> IO ()
+updateRcvFileChunkDelay db chunkId delay = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_file_chunks SET delay = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (delay, updatedAt, chunkId)
+
 updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> RcvFileId -> FilePath -> IO (Either StoreError RcvFile)
 updateRcvFileChunkReceived db rId cId fId chunkTmpPath = do
   updatedAt <- getCurrentTime
@@ -1850,7 +1856,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       db
       [sql|
         SELECT
-          f.user_id, f.rcv_file_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, c.next_delay,
+          f.user_id, f.rcv_file_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, c.delay,
           r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.acknowledged, r.retries
         FROM rcv_file_chunk_replicas r
         JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
@@ -1864,7 +1870,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       (host, port, keyHash)
   where
     toChunk :: ((UserId, RcvFileId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Bool, Int)) -> RcvFileChunk
-    toChunk ((userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, nextDelay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, acknowledged, retries)) =
+    toChunk ((userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, acknowledged, retries)) =
       RcvFileChunk
         { userId,
           rcvFileId,
@@ -1874,7 +1880,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
           digest,
           fileTmpPath,
           chunkTmpPath,
-          nextDelay,
+          delay,
           replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, acknowledged, retries}]
         }
 
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index 11cd45801..dd3f87853 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -43,7 +43,7 @@ CREATE TABLE rcv_file_chunks (
   chunk_size INTEGER NOT NULL,
   digest BLOB NOT NULL,
   tmp_path TEXT,
-  next_delay INTEGER,
+  delay INTEGER,
   created_at TEXT NOT NULL DEFAULT (datetime('now')),
   updated_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 13aa097a6..44514b705 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -315,7 +315,7 @@ CREATE TABLE rcv_file_chunks(
   chunk_size INTEGER NOT NULL,
   digest BLOB NOT NULL,
   tmp_path TEXT,
-  next_delay INTEGER,
+  delay INTEGER,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );

From e9f949f11791bc6adde581ba421694a019d78878 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Tue, 7 Mar 2023 13:29:28 +0400
Subject: [PATCH 48/71] xftp: resume file reception and decryption on agent
 restart (#673)

---
 src/Simplex/FileTransfer/Agent.hs           |  9 ++--
 src/Simplex/Messaging/Agent.hs              | 12 ++++-
 src/Simplex/Messaging/Agent/Store/SQLite.hs | 22 ++++++---
 tests/XFTPAgent.hs                          | 53 +++++++++++++++++----
 4 files changed, 77 insertions(+), 19 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 3e76bf579..a6669c20f 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -10,6 +10,7 @@
 
 module Simplex.FileTransfer.Agent
   ( receiveFile,
+    addXFTPWorker,
   )
 where
 
@@ -50,11 +51,11 @@ receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpPath
   where
     downloadChunk :: AgentMonad m => FileChunk -> m ()
     downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
-      addWorker c (Just server)
+      addXFTPWorker c (Just server)
     downloadChunk _ = throwError $ INTERNAL "no replicas"
 
-addWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
-addWorker c srv_ = do
+addXFTPWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m ()
+addXFTPWorker c srv_ = do
   ws <- asks $ xftpWorkers . xftpAgent
   atomically (TM.lookup srv_ ws) >>= \case
     Nothing -> do
@@ -104,7 +105,7 @@ runXFTPWorker c srv doWork = do
       -- check if chunk is downloaded and not acknowledged via flag acknowledged?
       -- or just catch and ignore error on acknowledgement? (and remove flag)
       -- agentXFTPAckChunk c replicaKey (unChunkReplicaId replicaId) `catchError` \_ -> pure ()
-      when fileReceived $ addWorker c Nothing
+      when fileReceived $ addXFTPWorker c Nothing
       where
         allChunksReceived :: RcvFile -> Bool
         allChunksReceived RcvFile {chunks} =
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 56d8a4e96..523425be0 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -114,7 +114,7 @@ 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 (receiveFile)
+import Simplex.FileTransfer.Agent (addXFTPWorker, receiveFile)
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Types (RcvFileId)
@@ -155,7 +155,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
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index c3db99806..31171ed5e 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -133,7 +133,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateRcvFileChunkReplicaRetries,
     getNextRcvChunkToDownload,
     getNextRcvFileToDecrypt,
-    getUnreceivedRcvFiles,
+    getPendingRcvFilesServers,
 
     -- * utilities
     withConnection,
@@ -1893,8 +1893,18 @@ getNextRcvFileToDecrypt db = do
     Nothing -> pure Nothing
     Just fileId -> eitherToMaybe <$> getRcvFile db fileId
 
-getUnreceivedRcvFiles :: DB.Connection -> IO [RcvFile]
-getUnreceivedRcvFiles _db = do
-  -- get unique file ids from rcv_files where status /= complete
-  -- getRcvFile for each file id
-  undefined
+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
+        WHERE r.received = 0 AND r.replica_number = 1
+      |]
+  where
+    toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
+    toServer (host, port, keyHash) = XFTPServer host port keyHash
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 2bca61a17..59f9fcf8e 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -12,11 +12,12 @@ import qualified Data.ByteString as LB
 import SMPAgentClient (agentCfg, initAgentServers)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
-import Simplex.Messaging.Agent (getSMPAgentClient, xftpReceiveFile)
+import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpReceiveFile)
 import Simplex.Messaging.Agent.Protocol (ACommand (FRCVD), AgentErrorType (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import System.Directory (getFileSize)
 import System.FilePath ((</>))
+import System.Timeout (timeout)
 import Test.Hspec
 import XFTPCLI
 import XFTPClient
@@ -24,6 +25,7 @@ import XFTPClient
 xftpAgentTests :: Spec
 xftpAgentTests = around_ testBracket . describe "Functional API" $ do
   it "should receive file" testXFTPAgentReceive
+  it "should resume receiving file after restart" testXFTPAgentReceiveRestore
 
 testXFTPAgentReceive :: IO ()
 testXFTPAgentReceive = withXFTPServer $ do
@@ -50,10 +52,45 @@ testXFTPAgentReceive = withXFTPServer $ do
     liftIO $ do
       fId' `shouldBe` fId
       LB.readFile path `shouldReturn` file
-  where
-    getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FPRecipient)
-    getFileDescription path = do
-      fd :: AFileDescription <- ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> LB.readFile path
-      vfd <- liftEither . first INTERNAL $ validateFileDescription fd
-      case vfd of
-        AVFD fd' -> either (throwError . INTERNAL) pure $ checkParty fd'
+
+getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FPRecipient)
+getFileDescription path = do
+  fd :: AFileDescription <- ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> LB.readFile path
+  vfd <- liftEither . first INTERNAL $ validateFileDescription fd
+  case vfd of
+    AVFD fd' -> either (throwError . INTERNAL) pure $ checkParty fd'
+
+testXFTPAgentReceiveRestore :: IO ()
+testXFTPAgentReceiveRestore = 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
+  runRight_ $ do
+    fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
+    void $ xftpReceiveFile rcp 1 fd recipientFiles
+    liftIO $ timeout 1000000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+  disconnectAgentClient rcp
+
+  rcp' <- getSMPAgentClient agentCfg initAgentServers
+  withXFTPServerStoreLogOn $ \_ -> do
+    -- receive file using agent - should succeed with server up
+    ("", "", FRCVD fId' path) <- get rcp'
+    liftIO $ do
+      fId' `shouldBe` 1
+      file <- LB.readFile filePath
+      LB.readFile path `shouldReturn` file

From 6d5215067237768b5f14ba018202f428c5149e97 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Wed, 8 Mar 2023 14:30:37 +0400
Subject: [PATCH 49/71] xftp: agent send file design wip (#674)

---
 simplexmq.cabal                               |  1 +
 src/Simplex/FileTransfer/Agent.hs             | 70 ++++++++++++++-
 src/Simplex/FileTransfer/Client.hs            |  2 +-
 src/Simplex/FileTransfer/Types.hs             | 79 ++++++++++++++++-
 src/Simplex/Messaging/Agent/Env/SQLite.hs     | 15 +++-
 .../SQLite/Migrations/M20230307_snd_files.hs  | 85 +++++++++++++++++++
 6 files changed, 247 insertions(+), 5 deletions(-)
 create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index 87a5fe16c..a0df76c41 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -76,6 +76,7 @@ library
       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.M20230307_snd_files
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index a6669c20f..c0d705d0e 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -9,8 +9,11 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.FileTransfer.Agent
-  ( receiveFile,
+  ( -- Receiving files
+    receiveFile,
     addXFTPWorker,
+    -- Sending files
+    sendFile,
   )
 where
 
@@ -179,3 +182,68 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
                 pure $ s <> chunk
             )
             LB.empty
+
+sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> FilePath -> m Int64
+sendFile c userId 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@AgentClient {subQ} 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
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index 124f433b5..d46971d64 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -73,7 +73,7 @@ data XFTPChunkSpec = XFTPChunkSpec
     chunkOffset :: Int64,
     chunkSize :: Word32
   }
-  deriving (Show)
+  deriving (Eq, Show)
 
 type XFTPClientError = ProtocolClientError XFTPErrorType
 
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index 64f5f0be7..a234528b1 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -9,6 +9,7 @@ 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 qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -46,7 +47,6 @@ data RcvFile = RcvFile
     tmpPath :: FilePath,
     saveDir :: FilePath,
     savePath :: Maybe FilePath,
-    status :: RcvFileStatus,
     status :: RcvFileStatus
   }
   deriving (Eq, Show)
@@ -100,3 +100,80 @@ data RcvFileChunkReplica = RcvFileChunkReplica
     retries :: Int
   }
   deriving (Eq, Show)
+
+-- Sending files
+
+type SndFileId = Int64
+
+data SndFile = SndFile
+  { userId :: Int64,
+    sndFileId :: SndFileId,
+    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 :: SndFileId,
+    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)
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index de256d317..b90b260dc 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -34,11 +34,14 @@ 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 (SndFileId)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store (UserId)
@@ -216,10 +219,18 @@ newNtfSubSupervisor qSize = do
   pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
 
 data XFTPAgent = XFTPAgent
-  { xftpWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ())
+  { 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 SndFileId)
   }
 
 newXFTPAgent :: STM XFTPAgent
 newXFTPAgent = do
   xftpWorkers <- TM.empty
-  pure XFTPAgent {xftpWorkers}
+  xftpSndWorkers <- TM.empty
+  xftpSndFiles <- newTVar S.empty
+  pure XFTPAgent {xftpWorkers, xftpSndWorkers, xftpSndFiles}
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs
new file mode 100644
index 000000000..3cfc96117
--- /dev/null
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230307_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
+m20230307_snd_files :: Query
+m20230307_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);
+|]

From 552759018e493cf224d2451a3dabee2401ab3853 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 9 Mar 2023 09:54:31 +0000
Subject: [PATCH 50/71] xftp: server types for any protocol (#672)

---
 simplexmq.cabal                            |  1 +
 src/Simplex/FileTransfer/Client/Main.hs    | 12 +--------
 src/Simplex/FileTransfer/Client/Presets.hs | 17 ++++++++++++
 src/Simplex/Messaging/Protocol.hs          | 30 +++++++++++++++++++---
 4 files changed, 45 insertions(+), 15 deletions(-)
 create mode 100644 src/Simplex/FileTransfer/Client/Presets.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index a0df76c41..d82e34a6f 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -39,6 +39,7 @@ library
       Simplex.FileTransfer.Client
       Simplex.FileTransfer.Client.Agent
       Simplex.FileTransfer.Client.Main
+      Simplex.FileTransfer.Client.Presets
       Simplex.FileTransfer.Description
       Simplex.FileTransfer.Protocol
       Simplex.FileTransfer.Server
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index e0f113ba5..6c29231bb 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -40,6 +40,7 @@ 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.Description
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
@@ -134,17 +135,6 @@ data RandomFileOptions = RandomFileOptions
 defaultRetryCount :: Int
 defaultRetryCount = 3
 
-defaultXFTPServers :: NonEmpty XFTPServerWithAuth
-defaultXFTPServers =
-  L.fromList
-    [ "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"
-    ]
-
 cliCommandP :: Parser CliCommand
 cliCommandP =
   hsubparser
diff --git a/src/Simplex/FileTransfer/Client/Presets.hs b/src/Simplex/FileTransfer/Client/Presets.hs
new file mode 100644
index 000000000..daf7b7be3
--- /dev/null
+++ b/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"
+  ]
diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs
index 5f23b1601..20e35aae5 100644
--- a/src/Simplex/Messaging/Protocol.hs
+++ b/src/Simplex/Messaging/Protocol.hs
@@ -65,6 +65,7 @@ module Simplex.Messaging.Protocol
     PrivHeader (..),
     Protocol (..),
     ProtocolType (..),
+    SProtocolType (..),
     AProtocolType (..),
     ProtocolTypeI (..),
     ProtocolServer (..),
@@ -78,6 +79,7 @@ module Simplex.Messaging.Protocol
     pattern XFTPServer,
     XFTPServerWithAuth,
     ProtoServerWithAuth (..),
+    AProtoServerWithAuth (..),
     BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
@@ -729,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
 
@@ -744,7 +748,7 @@ 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
@@ -780,10 +784,20 @@ data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer
 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
@@ -792,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
 
@@ -814,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))
 

From deec963de86197882fe0c5658f7ae4af8f3a4ac2 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 9 Mar 2023 15:32:17 +0400
Subject: [PATCH 51/71] xftp: agent error handling (#675)

- chunk download doesn't loop on permanent errors
- decryption errors are considered permanent - local worker doesn't retry
- update replica retries; to do - consider use for this field, or remove it
- rcv file Error status - to prevent repeat reads of chunks for download, files for decryption; also plan to use it for filtering on cleanup
- error string saved in separate field for debugging (not part of status type)
- agent event for rcv file errors
---
 src/Simplex/FileTransfer/Agent.hs             | 84 +++++++++++--------
 src/Simplex/FileTransfer/Types.hs             |  6 +-
 src/Simplex/Messaging/Agent/Protocol.hs       |  6 ++
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 39 ++++++---
 .../SQLite/Migrations/M20230223_files.hs      |  3 +-
 .../Store/SQLite/Migrations/agent_schema.sql  |  3 +-
 6 files changed, 91 insertions(+), 50 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index c0d705d0e..334ace1fd 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -13,10 +13,11 @@ module Simplex.FileTransfer.Agent
     receiveFile,
     addXFTPWorker,
     -- Sending files
-    sendFile,
+    _sendFile,
   )
 where
 
+import Control.Logger.Simple (logError)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -31,7 +32,7 @@ import Simplex.FileTransfer.Types
 import Simplex.FileTransfer.Util (uniqueCombine)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Protocol (ACommand (FRCVD), AParty (..), AgentErrorType (INTERNAL))
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
@@ -39,7 +40,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol (XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (whenM)
+import Simplex.Messaging.Util (tshow, whenM)
 import UnliftIO
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
@@ -77,31 +78,44 @@ runXFTPWorker c srv doWork = 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 fc@RcvFileChunk {rcvChunkId, delay} -> do
+        Just RcvFileChunk {rcvFileId, replicas = []} -> workerInternalError c rcvFileId "chunk has no replicas"
+        Just fc@RcvFileChunk {rcvFileId, rcvChunkId, delay, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId} : _} -> do
           ri <- asks $ reconnectInterval . config
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryInterval ri' $ \delay' loop ->
-            downloadFileChunk fc
-              `catchError` \_ -> do
-                withStore' c $ \db -> updateRcvFileChunkDelay db rcvChunkId delay'
-                -- TODO don't loop on permanent errors
-                -- TODO increase replica retries count
-                loop
-    noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    downloadFileChunk :: RcvFileChunk -> m ()
-    downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, replicas = replica : _} = do
+            downloadFileChunk fc replica
+              `catchError` retryOnError delay' loop (workerInternalError c rcvFileId . show)
+          where
+            retryOnError :: Int -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
+            retryOnError chunkDelay loop done e = do
+              logError $ "XFTP worker error: " <> tshow e
+              if temporaryAgentError e
+                then retryLoop
+                else done e
+              where
+                retryLoop = do
+                  withStore' c $ \db -> do
+                    updateRcvFileChunkDelay db rcvChunkId chunkDelay
+                    increaseRcvChunkReplicaRetries db rcvChunkReplicaId
+                  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
-        fd <- ExceptT $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId rcvFileId chunkPath
-        let fileReceived = allChunksReceived fd
+        f <- ExceptT $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId rcvFileId chunkPath
+        let fileReceived = allChunksReceived f
         when fileReceived $
           liftIO $ updateRcvFileStatus db rcvFileId RFSReceived
         pure fileReceived
@@ -113,7 +127,14 @@ runXFTPWorker c srv doWork = do
         allChunksReceived :: RcvFile -> Bool
         allChunksReceived RcvFile {chunks} =
           all (\RcvFileChunk {replicas} -> any received replicas) chunks
-    downloadFileChunk _ = throwError $ INTERNAL "no replica"
+
+workerInternalError :: AgentMonad m => AgentClient -> RcvFileId -> String -> m ()
+workerInternalError c rcvFileId internalErrStr = do
+  withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
+  notifyInternalError c rcvFileId internalErrStr
+
+notifyInternalError :: (MonadUnliftIO m) => AgentClient -> RcvFileId -> String -> m ()
+notifyInternalError AgentClient {subQ} rcvFileId internalErrStr = atomically $ writeTBQueue subQ ("", "", FRCVERR rcvFileId $ INTERNAL internalErrStr)
 
 runXFTPLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
 runXFTPLocalWorker c@AgentClient {subQ} doWork = do
@@ -126,14 +147,8 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
       nextFile <- withStore' c getNextRcvFileToDecrypt
       case nextFile of
         Nothing -> noWorkToDo
-        Just fd -> do
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop ->
-            decryptFile fd
-              `catchError` \_ -> do
-                -- TODO don't loop on permanent errors
-                -- TODO fixed number of retries instead of exponential backoff?
-                loop
+        Just f@RcvFile {rcvFileId} ->
+          decryptFile f `catchError` (workerInternalError c rcvFileId . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
     decryptFile RcvFile {rcvFileId, key, nonce, tmpPath, saveDir, chunks} = do
@@ -183,15 +198,16 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
             )
             LB.empty
 
-sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> FilePath -> m Int64
-sendFile c userId xftpPath filePath = do
+-- _sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> FilePath -> m Int64
+_sendFile :: AgentClient -> UserId -> FilePath -> FilePath -> m Int64
+_sendFile _c _userId _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@AgentClient {subQ} doWork = do
+_runXFTPSndLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
+_runXFTPSndLocalWorker _c doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     runXftpOperation
@@ -202,8 +218,8 @@ runXFTPSndLocalWorker c@AgentClient {subQ} doWork = do
       -- ? (or Encrypted to retry create? - see below)
       -- with fixed retries (?) encryptFile
       undefined
-    encryptFile :: SndFile -> m ()
-    encryptFile sndFile = do
+    _encryptFile :: SndFile -> m ()
+    _encryptFile _sndFile = do
       -- if enc path exists, remove it
       -- if enc path doesn't exist:
       --   - choose enc path
@@ -225,8 +241,8 @@ runXFTPSndLocalWorker c@AgentClient {subQ} doWork = do
       -- ? and add XFTP snd workers for uploading chunks.
       undefined
 
-runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m ()
-runXFTPSndWorker c srv doWork = do
+_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
@@ -238,8 +254,8 @@ runXFTPSndWorker c srv doWork = do
       --   - 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
+    _uploadFileChunk :: SndFileChunk -> m ()
+    _uploadFileChunk _sndFileChunk = do
       -- add file id to xftpSndFiles
       -- XFTP upload chunk
       -- db: update replica status to Uploaded, return SndFile
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index a234528b1..8b748a6eb 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -51,12 +51,12 @@ data RcvFile = RcvFile
   }
   deriving (Eq, Show)
 
--- TODO add error status?
 data RcvFileStatus
   = RFSReceiving
   | RFSReceived
   | RFSDecrypting
   | RFSComplete
+  | RFSError
   deriving (Eq, Show)
 
 instance FromField RcvFileStatus where fromField = fromTextField_ textDecode
@@ -69,12 +69,14 @@ instance TextEncoding RcvFileStatus where
     "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
   { userId :: Int64,
@@ -96,7 +98,7 @@ data RcvFileChunkReplica = RcvFileChunkReplica
     replicaId :: ChunkReplicaId,
     replicaKey :: C.APrivateSignKey,
     received :: Bool,
-    acknowledged :: Bool,
+    -- acknowledged :: Bool,
     retries :: Int
   }
   deriving (Eq, Show)
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index f1e7cec1d..c18e432fb 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -285,6 +285,7 @@ data ACommand (p :: AParty) where
   ERR :: AgentErrorType -> ACommand Agent
   SUSPENDED :: ACommand Agent
   FRCVD :: RcvFileId -> FilePath -> ACommand Agent
+  FRCVERR :: RcvFileId -> AgentErrorType -> ACommand Agent
 
 deriving instance Eq (ACommand p)
 
@@ -328,6 +329,7 @@ data ACommandTag (p :: AParty) where
   ERR_ :: ACommandTag Agent
   SUSPENDED_ :: ACommandTag Agent
   FRCVD_ :: ACommandTag Agent
+  FRCVERR_ :: ACommandTag Agent
 
 deriving instance Eq (ACommandTag p)
 
@@ -370,6 +372,7 @@ aCommandTag = \case
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
   FRCVD {} -> FRCVD_
+  FRCVERR {} -> FRCVERR_
 
 data QueueDirection = QDRcv | QDSnd
   deriving (Eq, Show)
@@ -1292,6 +1295,7 @@ instance APartyI p => StrEncoding (ACommandTag p) where
     ERR_ -> "ERR"
     SUSPENDED_ -> "SUSPENDED"
     FRCVD_ -> "FRCVD"
+    FRCVERR_ -> "FRCVERR"
   strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP
 
 checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p)
@@ -1343,6 +1347,7 @@ commandP binaryP =
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
           FRCVD_ -> s (FRCVD <$> A.decimal <* A.space <*> strP)
+          FRCVERR_ -> s (FRCVERR <$> A.decimal <* A.space <*> strP)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
@@ -1397,6 +1402,7 @@ serializeCommand = \case
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
   FRCVD fId fPath -> s (FRCVD_, Str $ bshow fId, fPath)
+  FRCVERR fId e -> s (FRCVERR_, Str $ bshow fId, e)
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 31171ed5e..859c1ac27 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -127,8 +127,10 @@ module Simplex.Messaging.Agent.Store.SQLite
     createRcvFile,
     getRcvFile,
     updateRcvFileChunkDelay,
+    increaseRcvChunkReplicaRetries,
     updateRcvFileChunkReceived,
     updateRcvFileStatus,
+    updateRcvFileError,
     updateRcvFileComplete,
     updateRcvFileChunkReplicaRetries,
     getNextRcvChunkToDownload,
@@ -1809,7 +1811,7 @@ getRcvFile db rcvFileId = runExceptT $ do
           db
           [sql|
             SELECT
-              r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.acknowledged, r.retries,
+              r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, 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
@@ -1817,16 +1819,21 @@ getRcvFile db rcvFileId = runExceptT $ do
           |]
           (Only chunkId)
       where
-        toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Bool, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
-        toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, acknowledged, retries, host, port, keyHash) =
+        toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
+        toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, retries, host, port, keyHash) =
           let server = XFTPServer host port keyHash
-           in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, acknowledged, retries}
+           in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, retries}
 
 updateRcvFileChunkDelay :: DB.Connection -> Int64 -> Int -> IO ()
 updateRcvFileChunkDelay db chunkId delay = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE rcv_file_chunks SET delay = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (delay, updatedAt, chunkId)
 
+increaseRcvChunkReplicaRetries :: DB.Connection -> Int64 -> IO ()
+increaseRcvChunkReplicaRetries db replicaId = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_file_chunk_replicas SET retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, replicaId)
+
 updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> RcvFileId -> FilePath -> IO (Either StoreError RcvFile)
 updateRcvFileChunkReceived db rId cId fId chunkTmpPath = do
   updatedAt <- getCurrentTime
@@ -1839,6 +1846,11 @@ 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 -> RcvFileId -> String -> IO ()
+updateRcvFileError db rcvFileId errStr = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_files SET error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId)
+
 updateRcvFileComplete :: DB.Connection -> RcvFileId -> FilePath -> IO ()
 updateRcvFileComplete db rcvFileId savePath = do
   updatedAt <- getCurrentTime
@@ -1857,20 +1869,20 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       [sql|
         SELECT
           f.user_id, f.rcv_file_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, c.delay,
-          r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.acknowledged, r.retries
+          r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, 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 r.received = 0 AND r.replica_number = 1 AND f.status = ?
         ORDER BY r.created_at ASC
         LIMIT 1
       |]
-      (host, port, keyHash)
+      (host, port, keyHash, RFSReceiving)
   where
-    toChunk :: ((UserId, RcvFileId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Bool, Int)) -> RcvFileChunk
-    toChunk ((userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, acknowledged, retries)) =
+    toChunk :: ((UserId, RcvFileId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Int)) -> RcvFileChunk
+    toChunk ((userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, retries)) =
       RcvFileChunk
         { userId,
           rcvFileId,
@@ -1881,7 +1893,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
           fileTmpPath,
           chunkTmpPath,
           delay,
-          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, acknowledged, retries}]
+          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, retries}]
         }
 
 getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
@@ -1896,15 +1908,18 @@ getNextRcvFileToDecrypt db = do
 getPendingRcvFilesServers :: DB.Connection -> IO [XFTPServer]
 getPendingRcvFilesServers db = do
   map toServer
-    <$> DB.query_
+    <$> 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
-        WHERE r.received = 0 AND r.replica_number = 1
+        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 = ?
       |]
+      (Only RFSReceiving)
   where
     toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
     toServer (host, port, keyHash) = XFTPServer host port keyHash
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index dd3f87853..dbfd0f5dc 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -30,6 +30,7 @@ CREATE TABLE rcv_files (
   save_dir TEXT NOT NULL,
   save_path TEXT,
   status TEXT NOT NULL,
+  error TEXT,
   created_at TEXT NOT NULL DEFAULT (datetime('now')),
   updated_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
@@ -58,7 +59,7 @@ CREATE TABLE rcv_file_chunk_replicas (
   replica_id BLOB NOT NULL,
   replica_key BLOB NOT NULL,
   received INTEGER NOT NULL DEFAULT 0,
-  acknowledged INTEGER NOT NULL DEFAULT 0,
+  -- acknowledged 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'))
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 44514b705..a96e6c847 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -304,6 +304,7 @@ CREATE TABLE rcv_files(
   save_dir TEXT NOT NULL,
   save_path TEXT,
   status TEXT NOT NULL,
+  error TEXT,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
@@ -328,7 +329,7 @@ CREATE TABLE rcv_file_chunk_replicas(
   replica_id BLOB NOT NULL,
   replica_key BLOB NOT NULL,
   received INTEGER NOT NULL DEFAULT 0,
-  acknowledged INTEGER NOT NULL DEFAULT 0,
+  -- acknowledged 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'))

From 8fde8e1344699cdcdc67709595c9285cd06bbef3 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 10 Mar 2023 09:10:52 +0000
Subject: [PATCH 52/71] xftp: agent command entities (#676)

* xftp: agent command entities

* progress event

* parameterize agent command by entity

* refactor

* Eq instance for APartyCmdTag
---
 src/Simplex/FileTransfer/Agent.hs             |   9 +-
 src/Simplex/Messaging/Agent.hs                |  88 ++--
 src/Simplex/Messaging/Agent/Client.hs         |  18 +-
 .../Messaging/Agent/NtfSubSupervisor.hs       |   8 +-
 src/Simplex/Messaging/Agent/Protocol.hs       | 415 +++++++++++-------
 src/Simplex/Messaging/Agent/Server.hs         |   8 +-
 src/Simplex/Messaging/Agent/Store.hs          |  10 +-
 tests/AgentTests.hs                           |  42 +-
 tests/AgentTests/FunctionalAPITests.hs        |  46 +-
 tests/SMPAgentClient.hs                       |   4 +-
 tests/XFTPAgent.hs                            |   8 +-
 11 files changed, 385 insertions(+), 271 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 334ace1fd..f86bc27db 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Agent
   ( -- Receiving files
@@ -134,7 +135,7 @@ workerInternalError c rcvFileId internalErrStr = do
   notifyInternalError c rcvFileId internalErrStr
 
 notifyInternalError :: (MonadUnliftIO m) => AgentClient -> RcvFileId -> String -> m ()
-notifyInternalError AgentClient {subQ} rcvFileId internalErrStr = atomically $ writeTBQueue subQ ("", "", FRCVERR rcvFileId $ INTERNAL internalErrStr)
+notifyInternalError AgentClient {subQ} rcvFileId internalErrStr = atomically $ writeTBQueue subQ ("", "", APC SAERcvFile $ RFERR rcvFileId $ INTERNAL internalErrStr)
 
 runXFTPLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m ()
 runXFTPLocalWorker c@AgentClient {subQ} doWork = do
@@ -159,10 +160,10 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
       path <- decrypt encSize chunkPaths
       whenM (doesPathExist tmpPath) $ removeDirectoryRecursive tmpPath
       withStore' c $ \db -> updateRcvFileComplete db rcvFileId path
-      notify $ FRCVD rcvFileId path
+      notify $ RFDONE rcvFileId path
       where
-        notify :: ACommand 'Agent -> m ()
-        notify cmd = atomically $ writeTBQueue subQ ("", "", cmd)
+        notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
+        notify cmd = atomically $ writeTBQueue subQ ("", "", APC (sAEntity @e) cmd)
         getChunkPaths :: [RcvFileChunk] -> m [FilePath]
         getChunkPaths [] = pure []
         getChunkPaths (RcvFileChunk {chunkTmpPath = Just path} : cs) = do
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 523425be0..91e9579e2 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -135,7 +135,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
@@ -379,29 +379,31 @@ runAgentClient c = race_ (subscriber c) (client c)
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env 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
@@ -419,12 +421,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
@@ -443,7 +445,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 =
@@ -453,7 +455,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
@@ -480,7 +482,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]
@@ -502,7 +504,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)
@@ -708,7 +710,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]
@@ -823,12 +825,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
@@ -915,7 +917,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
@@ -1124,9 +1127,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
@@ -1245,7 +1248,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
@@ -1259,7 +1262,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
@@ -1297,7 +1300,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
@@ -1513,7 +1516,7 @@ 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' c = atomically . writeTVar (ntfServers c)
@@ -1600,7 +1603,7 @@ cleanupManager c = do
         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)
 
 processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
 processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do
@@ -1714,7 +1717,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
@@ -1723,8 +1726,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
@@ -1805,7 +1811,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 ()
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 1ee467578..7ceaedcf4 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -413,8 +413,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
@@ -441,8 +441,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 :: ConnId -> ACommand 'Agent 'AEConn -> IO ()
+    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn cmd)
 
 getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
 getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
@@ -461,7 +461,7 @@ 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
@@ -482,7 +482,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@
     clientDisconnected client = do
       atomically $ TM.delete tSess xftpClients
       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
 
 getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
@@ -522,7 +522,7 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconne
           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
@@ -540,7 +540,7 @@ 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), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> Client msg -> ACommand 'Agent
+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
@@ -1059,7 +1059,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 ()
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 1a96fff16..459dc1206 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/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)
@@ -325,8 +324,9 @@ workerInternalError c connId internalErrStr = do
   withStore' c $ \db -> setNullNtfSubscriptionAction db connId
   notifyInternalError c connId internalErrStr
 
+-- TODO change error
 notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
-notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr)
+notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr)
 
 getNtfToken :: AgentMonad m => m (Maybe NtfToken)
 getNtfToken = do
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index c18e432fb..b73a04d06 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/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 (..),
@@ -165,6 +171,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( AProtocolType,
+    EntityId,
     ErrorType,
     MsgBody,
     MsgFlags,
@@ -211,10 +218,10 @@ 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 ACorrId = ByteString
 
@@ -242,100 +249,151 @@ 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 | AENone
+  deriving (Eq, Show)
+
+data SAEntity :: AEntity -> Type where
+  SAEConn :: SAEntity AEConn
+  SAERcvFile :: SAEntity AERcvFile
+  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 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 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
-  FRCVD :: RcvFileId -> FilePath -> ACommand Agent
-  FRCVERR :: RcvFileId -> AgentErrorType -> 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 AEConn
+  UP :: SMPServer -> [ConnId] -> ACommand Agent AEConn
+  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 :: RcvFileId -> Int -> Int -> ACommand Agent AERcvFile
+  RFDONE :: RcvFileId -> FilePath -> ACommand Agent AERcvFile
+  RFERR :: RcvFileId -> AgentErrorType -> ACommand Agent AERcvFile
 
-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
-  FRCVD_ :: ACommandTag Agent
-  FRCVERR_ :: 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 AEConn
+  UP_ :: ACommandTag Agent AEConn
+  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
+
+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_
@@ -371,8 +429,9 @@ aCommandTag = \case
   OK -> OK_
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
-  FRCVD {} -> FRCVD_
-  FRCVERR {} -> FRCVERR_
+  RFPROG {} -> RFPROG_
+  RFDONE {} -> RFDONE_
+  RFERR {} -> RFERR_
 
 data QueueDirection = QDRcv | QDSnd
   deriving (Eq, Show)
@@ -1219,46 +1278,57 @@ 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" -> at SAENone CONNECT_
+      "DISCONNECT" -> at SAENone DISCONNECT_
+      "DOWN" -> ct DOWN_
+      "UP" -> ct 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" -> at SAENone DEL_USER_
+      "CHK" -> t CHK_
+      "STAT" -> ct STAT_
+      "OK" -> ct OK_
+      "ERR" -> ct ERR_
+      "SUSPENDED" -> at SAENone SUSPENDED_
+      "RFPROG" -> at SAERcvFile RFPROG_
+      "RFDONE" -> at SAERcvFile RFDONE_
+      "RFERR" -> at SAERcvFile RFERR_
       _ -> fail "bad ACmdTag"
+    where
+      t = pure . ACmdTag SClient SAEConn
+      at e = pure . ACmdTag SAgent e
+      ct = at SAEConn
 
-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"
@@ -1294,22 +1364,28 @@ instance APartyI p => StrEncoding (ACommandTag p) where
     OK_ -> "OK"
     ERR_ -> "ERR"
     SUSPENDED_ -> "SUSPENDED"
-    FRCVD_ -> "FRCVD"
-    FRCVERR_ -> "FRCVERR"
-  strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP
+    RFPROG_ -> "RFPROG"
+    RFDONE_ -> "RFDONE"
+    RFERR_ -> "RFERR"
+  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)
@@ -1322,8 +1398,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)
@@ -1346,8 +1422,9 @@ commandP binaryP =
           OK_ -> pure OK
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
-          FRCVD_ -> s (FRCVD <$> A.decimal <* A.space <*> strP)
-          FRCVERR_ -> s (FRCVERR <$> A.decimal <* A.space <*> strP)
+          RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal)
+          RFDONE_ -> s (RFDONE <$> A.decimal <* A.space <*> strP)
+          RFERR_ -> s (RFERR <$> A.decimal <* A.space <*> strP)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
@@ -1365,7 +1442,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)
@@ -1401,8 +1478,9 @@ serializeCommand = \case
   ERR e -> s (ERR_, e)
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
-  FRCVD fId fPath -> s (FRCVD_, Str $ bshow fId, fPath)
-  FRCVERR fId e -> s (FRCVERR_, Str $ bshow fId, e)
+  RFPROG fId rcvd total -> s (RFPROG_, Str $ bshow fId, rcvd, total)
+  RFDONE fId fPath -> s (RFDONE_, Str $ bshow fId, fPath)
+  RFERR fId e -> s (RFERR_, Str $ bshow fId, e)
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
@@ -1435,52 +1513,55 @@ 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 =
diff --git a/src/Simplex/Messaging/Agent/Server.hs b/src/Simplex/Messaging/Agent/Server.hs
index 45b6be121..6ef9701f8 100644
--- a/src/Simplex/Messaging/Agent/Server.hs
+++ b/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]
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index 42c69398a..ab6e66820 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/src/Simplex/Messaging/Agent/Store.hs
@@ -277,20 +277,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 +363,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
diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs
index 77c61004e..43eb0c132 100644
--- a/tests/AgentTests.hs
+++ b/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,43 +83,53 @@ 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) <- tGet SAgent h
+  case cmdOrErr of
+    Right (APC _ CONNECT {}) -> tGetAgent' h
+    Right (APC _ DISCONNECT {}) -> tGetAgent' h
+    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)
 
 -- | receive message to handle `h`
-(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
 (<#:) = 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 :: AEntityTransmissionOrError p e -> AEntityTransmission p e
 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)
 
 -- | 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)
 
 -- | test that nothing is delivered to handle `h` during 10ms
@@ -129,7 +141,7 @@ h #:# err = tryGet `shouldReturn` ()
         Just _ -> error err
         _ -> return ()
 
-pattern Msg :: MsgBody -> ACommand 'Agent
+pattern Msg :: MsgBody -> ACommand 'Agent 'AEConn
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index efb877de3..2dfc9753b 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/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,8 @@ module AgentTests.FunctionalAPITests
     runRight,
     runRight_,
     get,
+    get',
+    rfGet,
     (##>),
     (=##>),
     pattern Msg,
@@ -38,6 +41,7 @@ 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
@@ -58,21 +62,31 @@ 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 ()
+(=##>) :: (HasCallStack, MonadIO m) => m (AEntityTransmission e) -> (AEntityTransmission e -> 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)
-  case cmd of
-    CONNECT {} -> get c
-    DISCONNECT {} -> get c
-    _ -> pure t
+get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn)
+get = get' @'AEConn
 
-pattern Msg :: MsgBody -> ACommand 'Agent
+rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile)
+rfGet = get' @'AERcvFile
+
+get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e)
+get' c = do
+  (corrId, connId, APC e cmd) <- atomically (readTBQueue $ subQ c)
+  case cmd of
+    CONNECT {} -> get' c
+    DISCONNECT {} -> get' c
+    _ -> case testEquality e (sAEntity @e) of
+      Just Refl -> pure (corrId, connId, cmd)
+      _ -> error $ "unexpected command " <> show cmd
+
+pattern Msg :: MsgBody -> ACommand 'Agent 'AEConn
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 smpCfgV1 :: ProtocolClientConfig
@@ -524,7 +538,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
@@ -551,11 +565,11 @@ testSuspendingAgentCompleteSending t = do
     liftIO $ threadDelay 100000
     suspendAgent b 5000000
 
-  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
+  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ 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
+    ("", "", SUSPENDED) <- get' @'AENone 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
@@ -581,7 +595,7 @@ testSuspendingAgentTimeout t = do
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
     6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
     suspendAgent b 100000
-    ("", "", SUSPENDED) <- get b
+    ("", "", SUSPENDED) <- get' @'AENone b
     pure ()
 
 testBatchedSubscriptions :: ATransport -> IO ()
@@ -777,7 +791,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
+    get' @'AENone a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
     exchangeGreetingsMsgId 6 a bId b aId
     liftIO $ noMessages a "nothing else should be delivered to alice"
 
@@ -813,7 +827,7 @@ testUsersNoServer t = 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
+    get' @'AENone 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
diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs
index 2687594d7..cc80cb098 100644
--- a/tests/SMPAgentClient.hs
+++ b/tests/SMPAgentClient.hs
@@ -66,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
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 59f9fcf8e..57b1e2777 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -5,7 +5,7 @@
 
 module XFTPAgent where
 
-import AgentTests.FunctionalAPITests (get, runRight_)
+import AgentTests.FunctionalAPITests (get, rfGet, runRight_)
 import Control.Monad.Except
 import Data.Bifunctor (first)
 import qualified Data.ByteString as LB
@@ -13,7 +13,7 @@ import SMPAgentClient (agentCfg, initAgentServers)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
 import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpReceiveFile)
-import Simplex.Messaging.Agent.Protocol (ACommand (FRCVD), AgentErrorType (..))
+import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import System.Directory (getFileSize)
 import System.FilePath ((</>))
@@ -48,7 +48,7 @@ testXFTPAgentReceive = withXFTPServer $ do
   runRight_ $ do
     fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
     fId <- xftpReceiveFile rcp 1 fd recipientFiles
-    ("", "", FRCVD fId' path) <- get rcp
+    ("", "", RFDONE fId' path) <- rfGet rcp
     liftIO $ do
       fId' `shouldBe` fId
       LB.readFile path `shouldReturn` file
@@ -89,7 +89,7 @@ testXFTPAgentReceiveRestore = do
   rcp' <- getSMPAgentClient agentCfg initAgentServers
   withXFTPServerStoreLogOn $ \_ -> do
     -- receive file using agent - should succeed with server up
-    ("", "", FRCVD fId' path) <- get rcp'
+    ("", "", RFDONE fId' path) <- rfGet rcp'
     liftIO $ do
       fId' `shouldBe` 1
       file <- LB.readFile filePath

From cc2066473c1ec365049318c6d1974a9a7553d946 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 10 Mar 2023 14:26:34 +0400
Subject: [PATCH 53/71] xftp: cleanup complete & error files tmp paths; remove
 save path before decrypting if exists (#677)

---
 src/Simplex/FileTransfer/Agent.hs             | 27 +++++-----
 src/Simplex/FileTransfer/Types.hs             |  2 +-
 src/Simplex/FileTransfer/Util.hs              |  8 ++-
 src/Simplex/Messaging/Agent.hs                | 15 ++++--
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 31 ++++++++----
 .../SQLite/Migrations/M20230223_files.hs      |  2 +-
 .../Store/SQLite/Migrations/agent_schema.sql  |  2 +-
 tests/XFTPAgent.hs                            | 50 +++++++++++++++++--
 8 files changed, 105 insertions(+), 32 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index f86bc27db..5154961c4 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -30,7 +30,7 @@ import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import Simplex.FileTransfer.Types
-import Simplex.FileTransfer.Util (uniqueCombine)
+import Simplex.FileTransfer.Util (removePath, uniqueCombine)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
@@ -41,7 +41,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol (XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (tshow, whenM)
+import Simplex.Messaging.Util (tshow)
 import UnliftIO
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
@@ -85,13 +85,13 @@ runXFTPWorker c srv doWork = do
       nextChunk <- withStore' c (`getNextRcvChunkToDownload` srv)
       case nextChunk of
         Nothing -> noWorkToDo
-        Just RcvFileChunk {rcvFileId, replicas = []} -> workerInternalError c rcvFileId "chunk has no replicas"
-        Just fc@RcvFileChunk {rcvFileId, rcvChunkId, delay, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId} : _} -> do
+        Just RcvFileChunk {rcvFileId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId (Just fileTmpPath) "chunk has no replicas"
+        Just fc@RcvFileChunk {rcvFileId, rcvChunkId, fileTmpPath, delay, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId} : _} -> 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 . show)
+              `catchError` retryOnError delay' loop (workerInternalError c rcvFileId (Just fileTmpPath) . show)
           where
             retryOnError :: Int -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
             retryOnError chunkDelay loop done e = do
@@ -129,8 +129,9 @@ runXFTPWorker c srv doWork = do
         allChunksReceived RcvFile {chunks} =
           all (\RcvFileChunk {replicas} -> any received replicas) chunks
 
-workerInternalError :: AgentMonad m => AgentClient -> RcvFileId -> String -> m ()
-workerInternalError c rcvFileId internalErrStr = do
+workerInternalError :: AgentMonad m => AgentClient -> RcvFileId -> Maybe FilePath -> String -> m ()
+workerInternalError c rcvFileId tmpPath internalErrStr = do
+  forM_ tmpPath removePath
   withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
   notifyInternalError c rcvFileId internalErrStr
 
@@ -148,17 +149,19 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
       nextFile <- withStore' c getNextRcvFileToDecrypt
       case nextFile of
         Nothing -> noWorkToDo
-        Just f@RcvFile {rcvFileId} ->
-          decryptFile f `catchError` (workerInternalError c rcvFileId . show)
+        Just f@RcvFile {rcvFileId, tmpPath} ->
+          decryptFile f `catchError` (workerInternalError c rcvFileId tmpPath . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
-    decryptFile RcvFile {rcvFileId, key, nonce, tmpPath, saveDir, chunks} = do
-      -- TODO remove tmpPath if exists
+    decryptFile RcvFile {rcvFileId, key, nonce, tmpPath, saveDir, savePath, chunks} = do
+      forM_ savePath $ \p -> do
+        removePath p
+        withStore' c (`updateRcvFileNoSavePath` rcvFileId)
       withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
       chunkPaths <- getChunkPaths chunks
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
       path <- decrypt encSize chunkPaths
-      whenM (doesPathExist tmpPath) $ removeDirectoryRecursive tmpPath
+      forM_ tmpPath removePath
       withStore' c $ \db -> updateRcvFileComplete db rcvFileId path
       notify $ RFDONE rcvFileId path
       where
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index 8b748a6eb..983bf9924 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -44,7 +44,7 @@ data RcvFile = RcvFile
     nonce :: C.CbNonce,
     chunkSize :: FileSize Word32,
     chunks :: [RcvFileChunk],
-    tmpPath :: FilePath,
+    tmpPath :: Maybe FilePath,
     saveDir :: FilePath,
     savePath :: Maybe FilePath,
     status :: RcvFileStatus
diff --git a/src/Simplex/FileTransfer/Util.hs b/src/Simplex/FileTransfer/Util.hs
index f8ac3d1f8..fad920747 100644
--- a/src/Simplex/FileTransfer/Util.hs
+++ b/src/Simplex/FileTransfer/Util.hs
@@ -1,9 +1,10 @@
 module Simplex.FileTransfer.Util
   ( uniqueCombine,
+    removePath,
   )
 where
 
-import Simplex.Messaging.Util (ifM)
+import Simplex.Messaging.Util (ifM, whenM)
 import System.FilePath (splitExtensions, (</>))
 import UnliftIO
 import UnliftIO.Directory
@@ -16,3 +17,8 @@ uniqueCombine filePath fileName = tryCombine (0 :: Int)
           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)
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 91e9579e2..2689f60e3 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -118,6 +118,7 @@ import Simplex.FileTransfer.Agent (addXFTPWorker, receiveFile)
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Types (RcvFileId)
+import Simplex.FileTransfer.Util (removePath)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock (withLock)
@@ -1597,13 +1598,21 @@ cleanupManager c = do
   threadDelay =<< asks (initialCleanupDelay . config)
   int <- asks (cleanupInterval . config)
   forever $ do
-    void . runExceptT $
+    void . runExceptT $ do
+      deleteConns
+      deleteTmpPaths
+      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) ("", "", APC SAENone $ DEL_USER userId)
+    deleteTmpPaths = do
+      tmpPaths <- withStore' c getTmpFilePaths
+      forM_ tmpPaths $ \(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
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 859c1ac27..ab4cfd8fb 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -132,10 +132,12 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateRcvFileStatus,
     updateRcvFileError,
     updateRcvFileComplete,
-    updateRcvFileChunkReplicaRetries,
+    updateRcvFileNoSavePath,
+    updateRcvFileNoTmpPath,
     getNextRcvChunkToDownload,
     getNextRcvFileToDecrypt,
     getPendingRcvFilesServers,
+    getTmpFilePaths,
 
     -- * utilities
     withConnection,
@@ -1767,7 +1769,7 @@ createRcvFile db userId fd@FileDescription {chunks} saveDir tmpPath = do
 getRcvFile :: DB.Connection -> RcvFileId -> IO (Either StoreError RcvFile)
 getRcvFile db rcvFileId = runExceptT $ do
   fd@RcvFile {userId, tmpPath} <- ExceptT getFile
-  chunks <- liftIO $ getChunks userId tmpPath
+  chunks <- maybe (pure []) (liftIO . getChunks userId) tmpPath
   pure (fd {chunks} :: RcvFile)
   where
     getFile :: IO (Either StoreError RcvFile)
@@ -1782,7 +1784,7 @@ getRcvFile db rcvFileId = runExceptT $ do
           |]
           (Only rcvFileId)
       where
-        toFile :: (UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile
+        toFile :: (UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile
         toFile (userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status) =
           RcvFile {userId, rcvFileId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status, chunks = []}
     getChunks :: UserId -> FilePath -> IO [RcvFileChunk]
@@ -1849,17 +1851,22 @@ updateRcvFileStatus db rcvFileId status = do
 updateRcvFileError :: DB.Connection -> RcvFileId -> String -> IO ()
 updateRcvFileError db rcvFileId errStr = do
   updatedAt <- getCurrentTime
-  DB.execute db "UPDATE rcv_files SET error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId)
+  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 -> RcvFileId -> FilePath -> IO ()
 updateRcvFileComplete db rcvFileId savePath = do
   updatedAt <- getCurrentTime
-  DB.execute db "UPDATE rcv_files SET save_path = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (savePath, RFSComplete, updatedAt, rcvFileId)
+  DB.execute db "UPDATE rcv_files SET tmp_path = NULL, save_path = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (savePath, RFSComplete, updatedAt, rcvFileId)
 
-updateRcvFileChunkReplicaRetries :: DB.Connection -> Int64 -> IO ()
-updateRcvFileChunkReplicaRetries _db _replicaId = do
-  -- update rcv_file_chunk_replicas
-  undefined
+updateRcvFileNoSavePath :: DB.Connection -> RcvFileId -> IO ()
+updateRcvFileNoSavePath db rcvFileId = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE rcv_files SET save_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId)
+
+updateRcvFileNoTmpPath :: DB.Connection -> RcvFileId -> 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)
 
 getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> IO (Maybe RcvFileChunk)
 getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
@@ -1900,7 +1907,7 @@ getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
 getNextRcvFileToDecrypt db = do
   fileId_ :: Maybe RcvFileId <-
     maybeFirstRow fromOnly $
-      DB.query db "SELECT rcv_file_id FROM rcv_files WHERE status = ? ORDER BY created_at ASC LIMIT 1" (Only RFSReceived)
+      DB.query db "SELECT rcv_file_id FROM rcv_files WHERE status IN (?,?) ORDER BY created_at ASC LIMIT 1" (RFSReceived, RFSDecrypting)
   case fileId_ of
     Nothing -> pure Nothing
     Just fileId -> eitherToMaybe <$> getRcvFile db fileId
@@ -1923,3 +1930,7 @@ getPendingRcvFilesServers db = do
   where
     toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
     toServer (host, port, keyHash) = XFTPServer host port keyHash
+
+getTmpFilePaths :: DB.Connection -> IO [(RcvFileId, FilePath)]
+getTmpFilePaths db =
+  DB.query db "SELECT rcv_file_id, tmp_path FROM rcv_files WHERE status IN (?,?) AND tmp_path IS NOT NULL" (RFSComplete, RFSError)
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index dbfd0f5dc..94c41f0b7 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -26,7 +26,7 @@ CREATE TABLE rcv_files (
   key BLOB NOT NULL,
   nonce BLOB NOT NULL,
   chunk_size INTEGER NOT NULL,
-  tmp_path TEXT NOT NULL,
+  tmp_path TEXT,
   save_dir TEXT NOT NULL,
   save_path TEXT,
   status TEXT NOT NULL,
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index a96e6c847..101cf0a6b 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -300,7 +300,7 @@ CREATE TABLE rcv_files(
   key BLOB NOT NULL,
   nonce BLOB NOT NULL,
   chunk_size INTEGER NOT NULL,
-  tmp_path TEXT NOT NULL,
+  tmp_path TEXT,
   save_dir TEXT NOT NULL,
   save_path TEXT,
   status TEXT NOT NULL,
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 57b1e2777..cb33d766e 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -5,7 +5,7 @@
 
 module XFTPAgent where
 
-import AgentTests.FunctionalAPITests (get, rfGet, runRight_)
+import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_)
 import Control.Monad.Except
 import Data.Bifunctor (first)
 import qualified Data.ByteString as LB
@@ -15,7 +15,7 @@ import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
 import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpReceiveFile)
 import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import System.Directory (getFileSize)
+import System.Directory (doesDirectoryExist, getFileSize)
 import System.FilePath ((</>))
 import System.Timeout (timeout)
 import Test.Hspec
@@ -26,6 +26,7 @@ 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
 
 testXFTPAgentReceive :: IO ()
 testXFTPAgentReceive = withXFTPServer $ do
@@ -83,9 +84,11 @@ testXFTPAgentReceiveRestore = do
   runRight_ $ do
     fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
     void $ xftpReceiveFile rcp 1 fd recipientFiles
-    liftIO $ timeout 1000000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
   disconnectAgentClient rcp
 
+  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` True
+
   rcp' <- getSMPAgentClient agentCfg initAgentServers
   withXFTPServerStoreLogOn $ \_ -> do
     -- receive file using agent - should succeed with server up
@@ -94,3 +97,44 @@ testXFTPAgentReceiveRestore = do
       fId' `shouldBe` 1
       file <- LB.readFile filePath
       LB.readFile path `shouldReturn` file
+
+  -- tmp path should be removed after receiving file
+  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
+
+testXFTPAgentReceiveCleanup :: IO ()
+testXFTPAgentReceiveCleanup = 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 'FPRecipient <- getFileDescription fdRcv
+    fId <- xftpReceiveFile rcp 1 fd recipientFiles
+    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    pure fId
+  disconnectAgentClient rcp
+
+  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` True
+
+  -- receive file using agent - should fail with AUTH error
+  rcp' <- getSMPAgentClient agentCfg initAgentServers
+  withXFTPServerThreadOn $ \_ -> do
+    ("", "", RFERR fId' (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
+    fId' `shouldBe` fId
+
+  -- tmp path should be removed after permanent error
+  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False

From accfee5a52b0d0c045539db503d782326613b79b Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 10 Mar 2023 10:32:05 +0000
Subject: [PATCH 54/71] 5.0.0-beta.4


From cf8f78f5182157cb013d8f74b8dbb1ad762c1e91 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 10 Mar 2023 20:32:37 +0400
Subject: [PATCH 55/71] xftp: add random bytestring entity id for rcv files
 (#681)

---
 src/Simplex/FileTransfer/Agent.hs             | 29 +++----
 src/Simplex/FileTransfer/Types.hs             | 19 +++--
 src/Simplex/Messaging/Agent.hs                |  1 -
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |  4 +-
 src/Simplex/Messaging/Agent/Protocol.hs       | 22 +++---
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 79 ++++++++++---------
 .../SQLite/Migrations/M20230223_files.hs      |  6 +-
 .../Store/SQLite/Migrations/agent_schema.sql  |  6 +-
 tests/XFTPAgent.hs                            | 21 +++--
 9 files changed, 104 insertions(+), 83 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 5154961c4..95a2ce04b 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -46,11 +46,12 @@ import UnliftIO
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 
-receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FPRecipient -> FilePath -> m Int64
+receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FPRecipient -> FilePath -> m RcvFileId
 receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpPath = do
+  g <- asks idsDrg
   encPath <- uniqueCombine xftpPath "xftp.encrypted"
   createDirectory encPath
-  fId <- withStore' c $ \db -> createRcvFile db userId fd xftpPath encPath
+  fId <- withStore c $ \db -> createRcvFile db g userId fd xftpPath encPath
   forM_ chunks downloadChunk
   pure fId
   where
@@ -85,13 +86,13 @@ runXFTPWorker c srv doWork = do
       nextChunk <- withStore' c (`getNextRcvChunkToDownload` srv)
       case nextChunk of
         Nothing -> noWorkToDo
-        Just RcvFileChunk {rcvFileId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId (Just fileTmpPath) "chunk has no replicas"
-        Just fc@RcvFileChunk {rcvFileId, rcvChunkId, fileTmpPath, delay, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId} : _} -> do
+        Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
+        Just fc@RcvFileChunk {rcvFileId, rcvFileEntityId, rcvChunkId, fileTmpPath, delay, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId} : _} -> 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 (Just fileTmpPath) . show)
+              `catchError` retryOnError delay' loop (workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) . show)
           where
             retryOnError :: Int -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
             retryOnError chunkDelay loop done e = do
@@ -129,14 +130,14 @@ runXFTPWorker c srv doWork = do
         allChunksReceived RcvFile {chunks} =
           all (\RcvFileChunk {replicas} -> any received replicas) chunks
 
-workerInternalError :: AgentMonad m => AgentClient -> RcvFileId -> Maybe FilePath -> String -> m ()
-workerInternalError c rcvFileId tmpPath internalErrStr = do
+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 rcvFileId internalErrStr
+  notifyInternalError c rcvFileEntityId internalErrStr
 
 notifyInternalError :: (MonadUnliftIO m) => AgentClient -> RcvFileId -> String -> m ()
-notifyInternalError AgentClient {subQ} rcvFileId internalErrStr = atomically $ writeTBQueue subQ ("", "", APC SAERcvFile $ RFERR rcvFileId $ INTERNAL internalErrStr)
+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
@@ -149,11 +150,11 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
       nextFile <- withStore' c getNextRcvFileToDecrypt
       case nextFile of
         Nothing -> noWorkToDo
-        Just f@RcvFile {rcvFileId, tmpPath} ->
-          decryptFile f `catchError` (workerInternalError c rcvFileId tmpPath . show)
+        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, key, nonce, tmpPath, saveDir, savePath, chunks} = do
+    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveDir, savePath, chunks} = do
       forM_ savePath $ \p -> do
         removePath p
         withStore' c (`updateRcvFileNoSavePath` rcvFileId)
@@ -163,10 +164,10 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
       path <- decrypt encSize chunkPaths
       forM_ tmpPath removePath
       withStore' c $ \db -> updateRcvFileComplete db rcvFileId path
-      notify $ RFDONE rcvFileId path
+      notify $ RFDONE path
       where
         notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
-        notify cmd = atomically $ writeTBQueue subQ ("", "", APC (sAEntity @e) cmd)
+        notify cmd = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC (sAEntity @e) cmd)
         getChunkPaths :: [RcvFileChunk] -> m [FilePath]
         getChunkPaths [] = pure []
         getChunkPaths (RcvFileChunk {chunkTmpPath = Just path} : cs) = do
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index 983bf9924..da673f4c9 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -11,6 +11,7 @@ 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
@@ -33,11 +34,12 @@ instance Encoding FileHeader where
     (fileName, fileExtra) <- smpP
     pure FileHeader {fileName, fileExtra}
 
-type RcvFileId = Int64
+type DBRcvFileId = Int64
 
 data RcvFile = RcvFile
-  { userId :: Int64,
-    rcvFileId :: RcvFileId,
+  { rcvFileId :: DBRcvFileId,
+    rcvFileEntityId :: RcvFileId,
+    userId :: Int64,
     size :: FileSize Int64,
     digest :: FileDigest,
     key :: C.SbKey,
@@ -79,8 +81,9 @@ instance TextEncoding RcvFileStatus where
     RFSError -> "error"
 
 data RcvFileChunk = RcvFileChunk
-  { userId :: Int64,
-    rcvFileId :: RcvFileId,
+  { rcvFileId :: DBRcvFileId,
+    rcvFileEntityId :: RcvFileId,
+    userId :: Int64,
     rcvChunkId :: Int64,
     chunkNo :: Int,
     chunkSize :: FileSize Word32,
@@ -105,11 +108,11 @@ data RcvFileChunkReplica = RcvFileChunkReplica
 
 -- Sending files
 
-type SndFileId = Int64
+type DBSndFileId = Int64
 
 data SndFile = SndFile
   { userId :: Int64,
-    sndFileId :: SndFileId,
+    sndFileId :: DBSndFileId,
     size :: FileSize Int64,
     digest :: FileDigest,
     key :: C.SbKey,
@@ -151,7 +154,7 @@ instance TextEncoding SndFileStatus where
 
 data SndFileChunk = SndFileChunk
   { userId :: Int64,
-    sndFileId :: SndFileId,
+    sndFileId :: DBSndFileId,
     sndChunkId :: Int64,
     chunkNo :: Int,
     chunkSpec :: XFTPChunkSpec,
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 2689f60e3..94c53848e 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -117,7 +117,6 @@ import qualified Database.SQLite.Simple as DB
 import Simplex.FileTransfer.Agent (addXFTPWorker, receiveFile)
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
-import Simplex.FileTransfer.Types (RcvFileId)
 import Simplex.FileTransfer.Util (removePath)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index b90b260dc..632b89961 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -41,7 +41,7 @@ import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
 import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig)
-import Simplex.FileTransfer.Types (SndFileId)
+import Simplex.FileTransfer.Types (DBSndFileId)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store (UserId)
@@ -225,7 +225,7 @@ data XFTPAgent = XFTPAgent
     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 SndFileId)
+    xftpSndFiles :: TVar (Set DBSndFileId)
   }
 
 newXFTPAgent :: STM XFTPAgent
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index b73a04d06..60b1d0d17 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -97,6 +97,7 @@ module Simplex.Messaging.Agent.Protocol
     ATransmissionOrError,
     ARawTransmission,
     ConnId,
+    RcvFileId,
     ConfirmationId,
     InvitationId,
     MsgIntegrity (..),
@@ -162,7 +163,6 @@ import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
 import Simplex.FileTransfer.Protocol (XFTPErrorType)
-import Simplex.FileTransfer.Types (RcvFileId)
 import Simplex.Messaging.Agent.QueryString
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
@@ -327,9 +327,9 @@ data ACommand (p :: AParty) (e :: AEntity) where
   ERR :: AgentErrorType -> ACommand Agent AEConn
   SUSPENDED :: ACommand Agent AENone
   -- XFTP commands and responses
-  RFPROG :: RcvFileId -> Int -> Int -> ACommand Agent AERcvFile
-  RFDONE :: RcvFileId -> FilePath -> ACommand Agent AERcvFile
-  RFERR :: RcvFileId -> AgentErrorType -> ACommand Agent AERcvFile
+  RFPROG :: Int -> Int -> ACommand Agent AERcvFile
+  RFDONE :: FilePath -> ACommand Agent AERcvFile
+  RFERR :: AgentErrorType -> ACommand Agent AERcvFile
 
 deriving instance Eq (ACommand p e)
 
@@ -880,6 +880,8 @@ connModeT = \case
 -- | SMP agent connection ID.
 type ConnId = ByteString
 
+type RcvFileId = ByteString
+
 type ConfirmationId = ByteString
 
 type InvitationId = ByteString
@@ -1422,9 +1424,9 @@ commandP binaryP =
           OK_ -> pure OK
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
-          RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal)
-          RFDONE_ -> s (RFDONE <$> A.decimal <* A.space <*> strP)
-          RFERR_ -> s (RFERR <$> A.decimal <* A.space <*> strP)
+          RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
+          RFDONE_ -> s (RFDONE <$> strP)
+          RFERR_ -> s (RFERR <$> strP)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
@@ -1478,9 +1480,9 @@ serializeCommand = \case
   ERR e -> s (ERR_, e)
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
-  RFPROG fId rcvd total -> s (RFPROG_, Str $ bshow fId, rcvd, total)
-  RFDONE fId fPath -> s (RFDONE_, Str $ bshow fId, fPath)
-  RFERR fId e -> s (RFERR_, Str $ bshow fId, e)
+  RFPROG rcvd total -> s (RFPROG_, rcvd, total)
+  RFDONE fPath -> s (RFDONE_, fPath)
+  RFERR e -> s (RFERR_, e)
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index ab4cfd8fb..2ff4b3dc0 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -1738,20 +1738,26 @@ 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 -> UserId -> FileDescription 'FPRecipient -> FilePath -> FilePath -> IO RcvFileId
-createRcvFile db userId fd@FileDescription {chunks} saveDir tmpPath = do
-  rcvFileId <- insertRcvFile fd
-  forM_ chunks $ \fc@FileChunk {replicas} -> do
-    chunkId <- insertChunk fc rcvFileId
-    forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertReplica rno replica chunkId
-  pure rcvFileId
+createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FPRecipient -> FilePath -> FilePath -> IO (Either StoreError RcvFileId)
+createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = 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 {size, digest, key, nonce, chunkSize} = do
-      DB.execute
-        db
-        "INSERT INTO rcv_files (user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, status) VALUES (?,?,?,?,?,?,?,?,?)"
-        (userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, RFSReceiving)
-      insertedRowId db
+    insertRcvFile :: FileDescription 'FPRecipient -> 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, tmp_path, save_dir, status) VALUES (?,?,?,?,?,?,?,?,?,?)"
+            (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, RFSReceiving)
+      rcvFileId <- liftIO $ insertedRowId db
+      pure (rcvFileEntityId, rcvFileId)
+    insertChunk :: FileChunk -> DBRcvFileId -> IO Int64
     insertChunk FileChunk {chunkNo, chunkSize, digest} rcvFileId = do
       DB.execute
         db
@@ -1766,10 +1772,10 @@ createRcvFile db userId fd@FileDescription {chunks} saveDir tmpPath = do
         "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)
 
-getRcvFile :: DB.Connection -> RcvFileId -> IO (Either StoreError RcvFile)
+getRcvFile :: DB.Connection -> DBRcvFileId -> IO (Either StoreError RcvFile)
 getRcvFile db rcvFileId = runExceptT $ do
-  fd@RcvFile {userId, tmpPath} <- ExceptT getFile
-  chunks <- maybe (pure []) (liftIO . getChunks userId) tmpPath
+  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)
@@ -1778,17 +1784,17 @@ getRcvFile db rcvFileId = runExceptT $ do
         DB.query
           db
           [sql|
-            SELECT user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, save_path, status
+            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, save_path, status
             FROM rcv_files
             WHERE rcv_file_id = ?
           |]
           (Only rcvFileId)
       where
-        toFile :: (UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile
-        toFile (userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status) =
-          RcvFile {userId, rcvFileId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status, chunks = []}
-    getChunks :: UserId -> FilePath -> IO [RcvFileChunk]
-    getChunks userId fileTmpPath = do
+        toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile
+        toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status) =
+          RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status, chunks = []}
+    getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk]
+    getChunks rcvFileEntityId userId fileTmpPath = do
       chunks <-
         map toChunk
           <$> DB.query
@@ -1805,7 +1811,7 @@ getRcvFile db rcvFileId = runExceptT $ do
       where
         toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath, Maybe Int) -> RcvFileChunk
         toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath, delay) =
-          RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay, replicas = []}
+          RcvFileChunk {rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay, replicas = []}
     getChunkReplicas :: Int64 -> IO [RcvFileChunkReplica]
     getChunkReplicas chunkId = do
       map toReplica
@@ -1836,34 +1842,34 @@ increaseRcvChunkReplicaRetries db replicaId = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE rcv_file_chunk_replicas SET retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, replicaId)
 
-updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> RcvFileId -> FilePath -> IO (Either StoreError RcvFile)
+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 -> RcvFileId -> RcvFileStatus -> IO ()
+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 -> RcvFileId -> String -> IO ()
+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 -> RcvFileId -> FilePath -> IO ()
+updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> FilePath -> IO ()
 updateRcvFileComplete db rcvFileId savePath = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE rcv_files SET tmp_path = NULL, save_path = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (savePath, RFSComplete, updatedAt, rcvFileId)
 
-updateRcvFileNoSavePath :: DB.Connection -> RcvFileId -> IO ()
+updateRcvFileNoSavePath :: DB.Connection -> DBRcvFileId -> IO ()
 updateRcvFileNoSavePath db rcvFileId = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE rcv_files SET save_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId)
 
-updateRcvFileNoTmpPath :: DB.Connection -> RcvFileId -> IO ()
+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)
@@ -1875,7 +1881,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       db
       [sql|
         SELECT
-          f.user_id, f.rcv_file_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, c.delay,
+          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, c.delay,
           r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.retries
         FROM rcv_file_chunk_replicas r
         JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
@@ -1888,11 +1894,12 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       |]
       (host, port, keyHash, RFSReceiving)
   where
-    toChunk :: ((UserId, RcvFileId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Int)) -> RcvFileChunk
-    toChunk ((userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, retries)) =
+    toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Int)) -> RcvFileChunk
+    toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, retries)) =
       RcvFileChunk
-        { userId,
-          rcvFileId,
+        { rcvFileId,
+          rcvFileEntityId,
+          userId,
           rcvChunkId,
           chunkNo,
           chunkSize,
@@ -1905,7 +1912,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
 
 getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
 getNextRcvFileToDecrypt db = do
-  fileId_ :: Maybe RcvFileId <-
+  fileId_ :: Maybe DBRcvFileId <-
     maybeFirstRow fromOnly $
       DB.query db "SELECT rcv_file_id FROM rcv_files WHERE status IN (?,?) ORDER BY created_at ASC LIMIT 1" (RFSReceived, RFSDecrypting)
   case fileId_ of
@@ -1931,6 +1938,6 @@ getPendingRcvFilesServers db = do
     toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
     toServer (host, port, keyHash) = XFTPServer host port keyHash
 
-getTmpFilePaths :: DB.Connection -> IO [(RcvFileId, FilePath)]
+getTmpFilePaths :: DB.Connection -> IO [(DBRcvFileId, FilePath)]
 getTmpFilePaths db =
   DB.query db "SELECT rcv_file_id, tmp_path FROM rcv_files WHERE status IN (?,?) AND tmp_path IS NOT NULL" (RFSComplete, RFSError)
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index 94c41f0b7..2ad06b4c8 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -19,7 +19,8 @@ CREATE TABLE xftp_servers (
 );
 
 CREATE TABLE rcv_files (
-  rcv_file_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  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,
@@ -32,7 +33,8 @@ CREATE TABLE rcv_files (
   status TEXT NOT NULL,
   error TEXT,
   created_at TEXT NOT NULL DEFAULT (datetime('now')),
-  updated_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);
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 101cf0a6b..ee7850191 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -293,7 +293,8 @@ CREATE TABLE xftp_servers(
   UNIQUE(xftp_host, xftp_port, xftp_key_hash)
 );
 CREATE TABLE rcv_files(
-  rcv_file_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  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,
@@ -306,7 +307,8 @@ CREATE TABLE rcv_files(
   status TEXT NOT NULL,
   error TEXT,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
-  updated_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(
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index cb33d766e..27d4afaf3 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -6,6 +6,7 @@
 module XFTPAgent where
 
 import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_)
+import Control.Logger.Simple
 import Control.Monad.Except
 import Data.Bifunctor (first)
 import qualified Data.ByteString as LB
@@ -49,7 +50,7 @@ testXFTPAgentReceive = withXFTPServer $ do
   runRight_ $ do
     fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
     fId <- xftpReceiveFile rcp 1 fd recipientFiles
-    ("", "", RFDONE fId' path) <- rfGet rcp
+    ("", fId', RFDONE path) <- rfGet rcp
     liftIO $ do
       fId' `shouldBe` fId
       LB.readFile path `shouldReturn` file
@@ -61,8 +62,11 @@ getFileDescription path = do
   case vfd of
     AVFD fd' -> either (throwError . INTERNAL) pure $ checkParty fd'
 
+logCfgNoLogs :: LogConfig
+logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
+
 testXFTPAgentReceiveRestore :: IO ()
-testXFTPAgentReceiveRestore = do
+testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
   let filePath = senderFiles </> "testfile"
       fdRcv = filePath <> ".xftp" </> "rcv1.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -81,10 +85,11 @@ testXFTPAgentReceiveRestore = do
 
   -- receive file using agent - should not succeed due to server being down
   rcp <- getSMPAgentClient agentCfg initAgentServers
-  runRight_ $ do
+  fId <- runRight $ do
     fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
-    void $ xftpReceiveFile rcp 1 fd recipientFiles
+    fId <- xftpReceiveFile rcp 1 fd recipientFiles
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
+    pure fId
   disconnectAgentClient rcp
 
   doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` True
@@ -92,9 +97,9 @@ testXFTPAgentReceiveRestore = do
   rcp' <- getSMPAgentClient agentCfg initAgentServers
   withXFTPServerStoreLogOn $ \_ -> do
     -- receive file using agent - should succeed with server up
-    ("", "", RFDONE fId' path) <- rfGet rcp'
+    ("", fId', RFDONE path) <- rfGet rcp'
     liftIO $ do
-      fId' `shouldBe` 1
+      fId' `shouldBe` fId
       file <- LB.readFile filePath
       LB.readFile path `shouldReturn` file
 
@@ -102,7 +107,7 @@ testXFTPAgentReceiveRestore = do
   doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
 
 testXFTPAgentReceiveCleanup :: IO ()
-testXFTPAgentReceiveCleanup = do
+testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
   let filePath = senderFiles </> "testfile"
       fdRcv = filePath <> ".xftp" </> "rcv1.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -133,7 +138,7 @@ testXFTPAgentReceiveCleanup = do
   -- receive file using agent - should fail with AUTH error
   rcp' <- getSMPAgentClient agentCfg initAgentServers
   withXFTPServerThreadOn $ \_ -> do
-    ("", "", RFERR fId' (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
+    ("", fId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
     fId' `shouldBe` fId
 
   -- tmp path should be removed after permanent error

From c1266d55a40f5554978d6e60ba59c1329ae66f78 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 10 Mar 2023 20:43:10 +0400
Subject: [PATCH 56/71] xftp: experimental send api wip (#682)

---
 src/Simplex/FileTransfer/Agent.hs       | 58 +++++++++++++++++++++++--
 src/Simplex/FileTransfer/Client/Main.hs |  5 ++-
 src/Simplex/Messaging/Agent.hs          |  7 ++-
 src/Simplex/Messaging/Agent/Protocol.hs | 19 +++++++-
 tests/AgentTests/FunctionalAPITests.hs  |  4 ++
 tests/XFTPAgent.hs                      | 32 +++++++++++++-
 6 files changed, 117 insertions(+), 8 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 95a2ce04b..8727f95cc 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -14,18 +14,27 @@ module Simplex.FileTransfer.Agent
     receiveFile,
     addXFTPWorker,
     -- 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 qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.List (isSuffixOf, partition)
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as L
+import Simplex.FileTransfer.Client.Main (CLIError, SendOptions (..), cliSendFile)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
@@ -42,7 +51,9 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol (XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (tshow)
+import System.FilePath (takeFileName, (</>))
 import UnliftIO
+import UnliftIO.Concurrent
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 
@@ -203,9 +214,50 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
             )
             LB.empty
 
--- _sendFile :: AgentMonad m => AgentClient -> UserId -> FilePath -> FilePath -> m Int64
-_sendFile :: AgentClient -> UserId -> FilePath -> FilePath -> m Int64
-_sendFile _c _userId _xftpPath _filePath = do
+sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId
+sendFileExperimental AgentClient {subQ} _userId numRecipients xftpPath filePath = do
+  g <- asks idsDrg
+  sndFileEntityId <- liftIO $ randomId g 12
+  void $ forkIO $ sendCLI sndFileEntityId
+  pure sndFileEntityId
+  where
+    randomId :: TVar ChaChaDRG -> Int -> IO ByteString
+    randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
+    sendCLI :: SndFileId -> m ()
+    sendCLI sndFileEntityId = do
+      let fileName = takeFileName filePath
+      outputDir <- uniqueCombine xftpPath (fileName <> ".descr")
+      createDirectory outputDir
+      let tempPath = xftpPath </> "snd"
+      createDirectoryIfMissing False tempPath
+      let sendOptions =
+            SendOptions
+              { filePath,
+                outputDir = Just outputDir,
+                numRecipients,
+                xftpServers = [],
+                retryCount = 3,
+                tempPath = Just tempPath,
+                verbose = False
+              }
+      liftCLI $ cliSendFile sendOptions
+      (sndDescr, rcvDescrs) <- readDescrs outputDir
+      notify sndFileEntityId $ SFDONE sndDescr rcvDescrs
+    liftCLI :: ExceptT CLIError IO () -> m ()
+    liftCLI = either (throwError . INTERNAL . show) pure <=< liftIO . runExceptT
+    readDescrs :: FilePath -> m (String, [String])
+    readDescrs outDir = do
+      files <- listDirectory outDir
+      let (sdFiles, rdFiles) = partition ("snd.xftp.private" `isSuffixOf`) files
+          sdFile = maybe "" L.head (nonEmpty sdFiles)
+      -- TODO map files to contents
+      pure (sdFile, rdFiles)
+    notify :: forall e. AEntityI e => SndFileId -> ACommand 'Agent e -> m ()
+    notify sndFileEntityId cmd = atomically $ writeTBQueue subQ ("", sndFileEntityId, 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
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 6c29231bb..26dc57ac2 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -10,7 +10,10 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Client.Main
-  ( xftpClientCLI,
+  ( SendOptions (..),
+    CLIError (..),
+    xftpClientCLI,
+    cliSendFile,
     prepareChunkSizes,
   )
 where
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 94c53848e..074a2d089 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -81,6 +81,7 @@ module Simplex.Messaging.Agent
     getNtfTokenData,
     toggleConnectionNtfs,
     xftpReceiveFile,
+    xftpSendFile,
     activateAgent,
     suspendAgent,
     execAgentStoreSQL,
@@ -114,7 +115,7 @@ 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, receiveFile)
+import Simplex.FileTransfer.Agent (addXFTPWorker, receiveFile, sendFileExperimental)
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Util (removePath)
@@ -341,6 +342,10 @@ toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c
 xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FPRecipient -> FilePath -> m RcvFileId
 xftpReceiveFile c = withAgentEnv c .:. receiveFile c
 
+-- | Send XFTP file
+xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId
+xftpSendFile c userId n xftpPath filePath = withAgentEnv c $ sendFileExperimental c userId n xftpPath filePath
+
 -- | Activate operations
 activateAgent :: AgentErrorMonad m => AgentClient -> m ()
 activateAgent c = withAgentEnv c $ activateAgent' c
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 60b1d0d17..9fd41da6a 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -98,6 +98,7 @@ module Simplex.Messaging.Agent.Protocol
     ARawTransmission,
     ConnId,
     RcvFileId,
+    SndFileId,
     ConfirmationId,
     InvitationId,
     MsgIntegrity (..),
@@ -249,12 +250,13 @@ instance APartyI Agent where sAParty = SAgent
 
 instance APartyI Client where sAParty = SClient
 
-data AEntity = AEConn | AERcvFile | AENone
+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)
@@ -264,6 +266,7 @@ 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
 
@@ -273,6 +276,8 @@ 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)
@@ -330,6 +335,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   RFPROG :: Int -> Int -> ACommand Agent AERcvFile
   RFDONE :: FilePath -> ACommand Agent AERcvFile
   RFERR :: AgentErrorType -> ACommand Agent AERcvFile
+  SFDONE :: String -> [String] -> ACommand Agent AESndFile
 
 deriving instance Eq (ACommand p e)
 
@@ -385,6 +391,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   RFDONE_ :: ACommandTag Agent AERcvFile
   RFPROG_ :: ACommandTag Agent AERcvFile
   RFERR_ :: ACommandTag Agent AERcvFile
+  SFDONE_ :: ACommandTag Agent AESndFile
 
 deriving instance Eq (ACommandTag p e)
 
@@ -432,6 +439,7 @@ aCommandTag = \case
   RFPROG {} -> RFPROG_
   RFDONE {} -> RFDONE_
   RFERR {} -> RFERR_
+  SFDONE {} -> SFDONE_
 
 data QueueDirection = QDRcv | QDSnd
   deriving (Eq, Show)
@@ -882,6 +890,8 @@ type ConnId = ByteString
 
 type RcvFileId = ByteString
 
+type SndFileId = ByteString
+
 type ConfirmationId = ByteString
 
 type InvitationId = ByteString
@@ -1369,6 +1379,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     RFPROG_ -> "RFPROG"
     RFDONE_ -> "RFDONE"
     RFERR_ -> "RFERR"
+    SFDONE_ -> "SFDONE"
   strP = (\(APCT _ t) -> checkEntity t) <$?> strP
 
 checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p)
@@ -1427,11 +1438,14 @@ commandP binaryP =
           RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
           RFDONE_ -> s (RFDONE <$> strP)
           RFERR_ -> s (RFERR <$> strP)
+          SFDONE_ -> s (SFDONE <$> strP <*> rcvDescrs)
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
     connections :: Parser [ConnId]
     connections = strP `A.sepBy'` A.char ','
+    rcvDescrs :: Parser [String]
+    rcvDescrs = strP `A.sepBy'` A.char ',' -- TODO consider separator
     msgMetaP = do
       integrity <- strP
       recipient <- " R=" *> partyMeta A.decimal
@@ -1483,6 +1497,7 @@ serializeCommand = \case
   RFPROG rcvd total -> s (RFPROG_, rcvd, total)
   RFDONE fPath -> s (RFDONE_, fPath)
   RFERR e -> s (RFERR_, e)
+  SFDONE sd rds -> B.unwords [s SFDONE_, s sd, rcvDescrs rds]
   where
     s :: StrEncoding a => a -> ByteString
     s = strEncode
@@ -1490,6 +1505,8 @@ serializeCommand = \case
     showTs = B.pack . formatISO8601Millis
     connections :: [ConnId] -> ByteString
     connections = B.intercalate "," . map strEncode
+    rcvDescrs :: [String] -> ByteString
+    rcvDescrs = B.intercalate "," . map strEncode -- TODO consider separator
     serializeMsgMeta :: MsgMeta -> ByteString
     serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
       B.unwords
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index 2dfc9753b..c4adaabaf 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -22,6 +22,7 @@ module AgentTests.FunctionalAPITests
     get,
     get',
     rfGet,
+    sfGet,
     (##>),
     (=##>),
     pattern Msg,
@@ -76,6 +77,9 @@ get = get' @'AEConn
 rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile)
 rfGet = get' @'AERcvFile
 
+sfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AESndFile)
+sfGet = get' @'AESndFile
+
 get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e)
 get' c = do
   (corrId, connId, APC e cmd) <- atomically (readTBQueue $ subQ c)
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 27d4afaf3..5b9f54157 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -5,7 +5,7 @@
 
 module XFTPAgent where
 
-import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_)
+import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Data.Bifunctor (first)
@@ -13,7 +13,7 @@ import qualified Data.ByteString as LB
 import SMPAgentClient (agentCfg, initAgentServers)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
-import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpReceiveFile)
+import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpReceiveFile, xftpSendFile)
 import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import System.Directory (doesDirectoryExist, getFileSize)
@@ -28,6 +28,7 @@ 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
+  xit "should send file using experimental api" testXFTPAgentSendExperimental -- TODO uses default servers (remote)
 
 testXFTPAgentReceive :: IO ()
 testXFTPAgentReceive = withXFTPServer $ do
@@ -143,3 +144,30 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
 
   -- tmp path should be removed after permanent error
   doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
+
+testXFTPAgentSendExperimental :: IO ()
+-- testXFTPAgentSendExperimental = withXFTPServer $ do
+testXFTPAgentSendExperimental = do
+  -- create random file using cli
+  let filePath = senderFiles </> "testfile"
+  xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
+  file <- LB.readFile filePath
+  getFileSize filePath `shouldReturn` mb 17
+
+  -- send file using experimental agent API
+  sndr <- getSMPAgentClient agentCfg initAgentServers
+  runRight_ $ do
+    sfId <- xftpSendFile sndr 1 2 senderFiles filePath
+    ("", sfId', SFDONE _ _) <- sfGet sndr
+    liftIO $ sfId' `shouldBe` sfId
+  let fdRcv = senderFiles </> "testfile.descr/testfile.xftp/rcv1.xftp" -- TODO use from SFDONE
+
+  -- receive file using agent
+  rcp <- getSMPAgentClient agentCfg initAgentServers
+  runRight_ $ do
+    fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
+    rfId <- xftpReceiveFile rcp 1 fd recipientFiles
+    ("", rfId', RFDONE path) <- rfGet rcp
+    liftIO $ do
+      rfId' `shouldBe` rfId
+      LB.readFile path `shouldReturn` file

From 40164ff21f459249ed231401946a00d68e1447c2 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 10 Mar 2023 16:59:26 +0000
Subject: [PATCH 57/71] update http2 to 4.1 (#680)

---
 cabal.project   |  2 +-
 package.yaml    |  2 +-
 simplexmq.cabal | 14 +++++++-------
 stack.yaml      |  2 ++
 4 files changed, 11 insertions(+), 9 deletions(-)

diff --git a/cabal.project b/cabal.project
index bf2ebeaa4..5c6895cdd 100644
--- a/cabal.project
+++ b/cabal.project
@@ -15,7 +15,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kazu-yamamoto/http2.git
-    tag: b3b62ba36900babfde1a073c705cbccc2685f385
+    tag: 78e18f52295a7f89e828539a03fbcb24931461a3
 
 source-repository-package
     type: git
diff --git a/package.yaml b/package.yaml
index fd23c72c2..86e2d70be 100644
--- a/package.yaml
+++ b/package.yaml
@@ -42,7 +42,7 @@ dependencies:
   - directory == 1.3.*
   - filepath == 1.4.*
   - http-types == 0.12.*
-  - http2 == 4.0.*
+  - http2 == 4.1.*
   - generic-random >= 1.3 && < 1.5
   - ini == 0.4.1
   - iso8601-time == 0.1.*
diff --git a/simplexmq.cabal b/simplexmq.cabal
index d82e34a6f..422ea01e8 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -151,7 +151,7 @@ library
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -214,7 +214,7 @@ executable ntf-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -278,7 +278,7 @@ executable smp-agent
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -342,7 +342,7 @@ executable smp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -406,7 +406,7 @@ executable xftp
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -470,7 +470,7 @@ executable xftp-server
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , memory ==0.15.*
@@ -561,7 +561,7 @@ test-suite simplexmq-test
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==4.0.*
+    , http2 ==4.1.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
     , main-tester ==0.2.*
diff --git a/stack.yaml b/stack.yaml
index 0cc68455c..1835dec0e 100644
--- a/stack.yaml
+++ b/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

From cf1cd75a154bccaec7118eba6ebed60654b98dc3 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 10 Mar 2023 21:06:09 +0400
Subject: [PATCH 58/71] xftp: fix experimental send api description paths
 (#683)

---
 src/Simplex/FileTransfer/Agent.hs | 14 ++++++++------
 tests/XFTPAgent.hs                | 14 ++++++++++----
 2 files changed, 18 insertions(+), 10 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 8727f95cc..c89e40ae5 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -241,17 +241,19 @@ sendFileExperimental AgentClient {subQ} _userId numRecipients xftpPath filePath
                 verbose = False
               }
       liftCLI $ cliSendFile sendOptions
-      (sndDescr, rcvDescrs) <- readDescrs outputDir
+      (sndDescr, rcvDescrs) <- readDescrs outputDir fileName
       notify sndFileEntityId $ SFDONE sndDescr rcvDescrs
     liftCLI :: ExceptT CLIError IO () -> m ()
     liftCLI = either (throwError . INTERNAL . show) pure <=< liftIO . runExceptT
-    readDescrs :: FilePath -> m (String, [String])
-    readDescrs outDir = do
-      files <- listDirectory outDir
+    readDescrs :: FilePath -> FilePath -> m (String, [String])
+    readDescrs outDir fileName = do
+      let descrDir = outDir </> (fileName <> ".xftp")
+      files <- listDirectory descrDir
       let (sdFiles, rdFiles) = partition ("snd.xftp.private" `isSuffixOf`) files
-          sdFile = maybe "" L.head (nonEmpty sdFiles)
+          sdFile = maybe "" (\l -> descrDir </> L.head l) (nonEmpty sdFiles)
+          rdFiles' = map (descrDir </>) rdFiles
       -- TODO map files to contents
-      pure (sdFile, rdFiles)
+      pure (sdFile, rdFiles')
     notify :: forall e. AEntityI e => SndFileId -> ACommand 'Agent e -> m ()
     notify sndFileEntityId cmd = atomically $ writeTBQueue subQ ("", sndFileEntityId, APC (sAEntity @e) cmd)
 
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 5b9f54157..a5046d47b 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -10,6 +10,8 @@ import Control.Logger.Simple
 import Control.Monad.Except
 import Data.Bifunctor (first)
 import qualified Data.ByteString as LB
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as L
 import SMPAgentClient (agentCfg, initAgentServers)
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
@@ -156,11 +158,15 @@ testXFTPAgentSendExperimental = do
 
   -- send file using experimental agent API
   sndr <- getSMPAgentClient agentCfg initAgentServers
-  runRight_ $ do
+  rcvDescrs <- runRight $ do
     sfId <- xftpSendFile sndr 1 2 senderFiles filePath
-    ("", sfId', SFDONE _ _) <- sfGet sndr
-    liftIO $ sfId' `shouldBe` sfId
-  let fdRcv = senderFiles </> "testfile.descr/testfile.xftp/rcv1.xftp" -- TODO use from SFDONE
+    ("", sfId', SFDONE sndDescr rcvDescrs) <- sfGet sndr
+    liftIO $ do
+      sfId' `shouldBe` sfId
+      sndDescr `shouldBe` senderFiles </> "testfile.descr/testfile.xftp/snd.xftp.private"
+      rcvDescrs `shouldBe` [senderFiles </> "testfile.descr/testfile.xftp/rcv1.xftp", senderFiles </> "testfile.descr/testfile.xftp/rcv2.xftp"]
+    pure rcvDescrs
+  let fdRcv = maybe "" L.head (nonEmpty rcvDescrs)
 
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers

From 448b674fb1e449d6893a92ef4d0bb7ccb0aa7b8f Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 10 Mar 2023 17:37:38 +0000
Subject: [PATCH 59/71] 5.0.0-beta.5


From 3fe1f3c82234674da94558aca7476e1df0f91be4 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 11 Mar 2023 10:05:07 +0000
Subject: [PATCH 60/71] rename FileParty constructors

---
 src/Simplex/FileTransfer/Agent.hs           |  2 +-
 src/Simplex/FileTransfer/Client/Main.hs     | 22 +++---
 src/Simplex/FileTransfer/Description.hs     |  7 +-
 src/Simplex/FileTransfer/Protocol.hs        | 80 ++++++++++-----------
 src/Simplex/FileTransfer/Server.hs          |  4 +-
 src/Simplex/FileTransfer/Server/Store.hs    |  4 +-
 src/Simplex/Messaging/Agent.hs              |  2 +-
 src/Simplex/Messaging/Agent/Store/SQLite.hs |  4 +-
 tests/FileDescriptionTests.hs               |  6 +-
 tests/XFTPAgent.hs                          | 10 +--
 10 files changed, 72 insertions(+), 69 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index c89e40ae5..b8847cdbf 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -57,7 +57,7 @@ import UnliftIO.Concurrent
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 
-receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FPRecipient -> FilePath -> m RcvFileId
+receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> FilePath -> m RcvFileId
 receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpPath = do
   g <- asks idsDrg
   encPath <- uniqueCombine xftpPath "xftp.encrypted"
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 26dc57ac2..1c0e30574 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -268,7 +268,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
     putStrLn "Pass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
   where
-    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec], Int64)
+    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
     encryptFile fileName = do
       fileSize <- fromInteger <$> getFileSize filePath
       when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
@@ -284,8 +284,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
       encrypt fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
-          fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
-          fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+          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)
       where
@@ -342,8 +342,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
     -- M chunks, R replicas, N recipients
     -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
     -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
-    createRcvFileDescriptions :: FileDescription 'FPRecipient -> [SentFileChunk] -> [FileDescription 'FPRecipient]
-    createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FPRecipient)) {chunks}) rcvChunks
+    createRcvFileDescriptions :: FileDescription 'FRecipient -> [SentFileChunk] -> [FileDescription 'FRecipient]
+    createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
       where
         rcvReplicas :: [SentRecipientReplica]
         rcvReplicas =
@@ -374,7 +374,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
               Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas}
               _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
             replica = FileChunkReplica {server, replicaId, replicaKey}
-    createSndFileDescription :: FileDescription 'FPSender -> [SentFileChunk] -> FileDescription 'FPSender
+    createSndFileDescription :: FileDescription 'FSender -> [SentFileChunk] -> FileDescription 'FSender
     createSndFileDescription fd sentChunks = fd {chunks = sndChunks}
       where
         sndChunks :: [FileChunk]
@@ -389,7 +389,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
         sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica]
         sndReplicas [] _ _ = []
         sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}]
-    writeFileDescriptions :: String -> [FileDescription 'FPRecipient] -> FileDescription 'FPSender -> IO ([FilePath], FilePath)
+    writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath)
     writeFileDescriptions fileName fdRcvs fdSnd = do
       outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
       createDirectoryIfMissing True outDir
@@ -405,7 +405,7 @@ cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
   getFileDescription' fileDescription >>= receiveFile
   where
-    receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
+    receiveFile :: ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
     receiveFile (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do
       encPath <- getEncPath tempPath "xftp"
       createDirectory encPath
@@ -486,7 +486,7 @@ cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
 cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
   getFileDescription' fileDescription >>= deleteFile
   where
-    deleteFile :: ValidFileDescription 'FPSender -> ExceptT CLIError IO ()
+    deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO ()
     deleteFile (ValidFileDescription FileDescription {chunks}) = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       forM_ chunks $ deleteFileChunk a
@@ -516,8 +516,8 @@ cliFileDescrInfo InfoOptions {fileDescription} = do
       where
         printParty :: IO ()
         printParty = case party of
-          SRecipient -> putStrLn "Recipient file description"
-          SSender -> putStrLn "Sender file description"
+          SFRecipient -> putStrLn "Recipient file description"
+          SFSender -> putStrLn "Sender file description"
 
 strEnc :: StrEncoding a => a -> String
 strEnc = B.unpack . strEncode
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index ff3d7e144..f9bb5c52d 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -39,8 +39,6 @@ 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 Database.SQLite.Simple.FromField (FromField (..))
-import Database.SQLite.Simple.ToField (ToField (..))
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -53,6 +51,8 @@ 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
@@ -226,12 +226,15 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
 
 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
diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs
index 8f793114f..a10917a61 100644
--- a/src/Simplex/FileTransfer/Protocol.hs
+++ b/src/Simplex/FileTransfer/Protocol.hs
@@ -68,23 +68,23 @@ xftpBlockSize :: Int
 xftpBlockSize = 16384
 
 -- | File protocol clients
-data FileParty = FPRecipient | FPSender
+data FileParty = FRecipient | FSender
   deriving (Eq, Show, Generic)
 
 instance FromJSON FileParty where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "FP"
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "F"
 
 instance ToJSON FileParty where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "FP"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "FP"
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "F"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "F"
 
 data SFileParty :: FileParty -> Type where
-  SRecipient :: SFileParty FPRecipient
-  SSender :: SFileParty FPSender
+  SFRecipient :: SFileParty FRecipient
+  SFSender :: SFileParty FSender
 
 instance TestEquality SFileParty where
-  testEquality SRecipient SRecipient = Just Refl
-  testEquality SSender SSender = Just Refl
+  testEquality SFRecipient SFRecipient = Just Refl
+  testEquality SFSender SFSender = Just Refl
   testEquality _ _ = Nothing
 
 deriving instance Eq (SFileParty p)
@@ -95,28 +95,28 @@ data AFileParty = forall p. FilePartyI p => AFP (SFileParty p)
 
 toFileParty :: SFileParty p -> FileParty
 toFileParty = \case
-  SRecipient -> FPRecipient
-  SSender -> FPSender
+  SFRecipient -> FRecipient
+  SFSender -> FSender
 
 aFileParty :: FileParty -> AFileParty
 aFileParty = \case
-  FPRecipient -> AFP SRecipient
-  FPSender -> AFP SSender
+  FRecipient -> AFP SFRecipient
+  FSender -> AFP SFSender
 
 class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p
 
-instance FilePartyI FPRecipient where sFileParty = SRecipient
+instance FilePartyI FRecipient where sFileParty = SFRecipient
 
-instance FilePartyI FPSender where sFileParty = SSender
+instance FilePartyI FSender where sFileParty = SFSender
 
 data FileCommandTag (p :: FileParty) where
-  FNEW_ :: FileCommandTag FPSender
-  FADD_ :: FileCommandTag FPSender
-  FPUT_ :: FileCommandTag FPSender
-  FDEL_ :: FileCommandTag FPSender
-  FGET_ :: FileCommandTag FPRecipient
-  FACK_ :: FileCommandTag FPRecipient
-  PING_ :: FileCommandTag FPRecipient
+  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)
 
@@ -139,13 +139,13 @@ instance Encoding FileCmdTag where
 
 instance ProtocolMsgTag FileCmdTag where
   decodeTag = \case
-    "FNEW" -> Just $ FCT SSender FNEW_
-    "FADD" -> Just $ FCT SSender FADD_
-    "FPUT" -> Just $ FCT SSender FPUT_
-    "FDEL" -> Just $ FCT SSender FDEL_
-    "FGET" -> Just $ FCT SRecipient FGET_
-    "FACK" -> Just $ FCT SRecipient FACK_
-    "PING" -> Just $ FCT SRecipient PING_
+    "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
@@ -155,19 +155,19 @@ instance Protocol XFTPErrorType FileResponse where
   type ProtoCommand FileResponse = FileCmd
   type ProtoType FileResponse = 'PXFTP
   protocolClientHandshake = ntfClientHandshake
-  protocolPing = FileCmd SRecipient PING
+  protocolPing = FileCmd SFRecipient PING
   protocolError = \case
     FRErr e -> Just e
     _ -> Nothing
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FPSender
-  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
-  FPUT :: FileCommand FPSender
-  FDEL :: FileCommand FPSender
-  FGET :: RcvPublicDhKey -> FileCommand FPRecipient
-  FACK :: FileCommand FPRecipient
-  PING :: FileCommand FPRecipient
+  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)
 
@@ -222,14 +222,14 @@ instance ProtocolEncoding XFTPErrorType FileCmd where
   encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
 
   protocolP _v = \case
-    FCT SSender tag ->
-      FileCmd SSender <$> case tag of
+    FCT SFSender tag ->
+      FileCmd SFSender <$> case tag of
         FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
-    FCT SRecipient tag ->
-      FileCmd SRecipient <$> case tag of
+    FCT SFRecipient tag ->
+      FileCmd SFRecipient <$> case tag of
         FGET_ -> FGET <$> _smpP
         FACK_ -> pure FACK
         PING_ -> pure PING
diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index b8ad9b2e6..8e9c8a1e6 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -201,8 +201,8 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed
 verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
 verifyXFTPTransmission sig_ signed fId cmd =
   case cmd of
-    FileCmd SSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
-    FileCmd SRecipient PING -> pure $ VRVerified XFTPReqPing
+    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
diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs
index 2a19cb219..ce399cea6 100644
--- a/src/Simplex/FileTransfer/Server/Store.hs
+++ b/src/Simplex/FileTransfer/Server/Store.hs
@@ -115,8 +115,8 @@ deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do
 
 getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey))
 getFile st party fId = case party of
-  SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
-  SRecipient ->
+  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
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 074a2d089..e615d76c8 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -339,7 +339,7 @@ toggleConnectionNtfs :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m
 toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c
 
 -- | Receive XFTP file
-xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FPRecipient -> FilePath -> m RcvFileId
+xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> FilePath -> m RcvFileId
 xftpReceiveFile c = withAgentEnv c .:. receiveFile c
 
 -- | Send XFTP file
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 2ff4b3dc0..9d5e5e14e 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -1738,7 +1738,7 @@ 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 'FPRecipient -> FilePath -> FilePath -> IO (Either StoreError RcvFileId)
+createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> IO (Either StoreError RcvFileId)
 createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = runExceptT $ do
   (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd
   liftIO $
@@ -1747,7 +1747,7 @@ createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = runEx
       forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertReplica rno replica chunkId
   pure rcvFileEntityId
   where
-    insertRcvFile :: FileDescription 'FPRecipient -> IO (Either StoreError (RcvFileId, DBRcvFileId))
+    insertRcvFile :: FileDescription 'FRecipient -> IO (Either StoreError (RcvFileId, DBRcvFileId))
     insertRcvFile FileDescription {size, digest, key, nonce, chunkSize} = runExceptT $ do
       rcvFileEntityId <- ExceptT $
         createWithRandomId gVar $ \rcvFileEntityId ->
diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs
index f02945406..676882bcd 100644
--- a/tests/FileDescriptionTests.hs
+++ b/tests/FileDescriptionTests.hs
@@ -36,10 +36,10 @@ testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTF
 testCbNonce :: C.CbNonce
 testCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
 
-fileDesc :: FileDescription 'FPRecipient
+fileDesc :: FileDescription 'FRecipient
 fileDesc =
   FileDescription
-    { party = SRecipient,
+    { party = SFRecipient,
       size = FileSize $ mb 26,
       digest = FileDigest "abc",
       key = testSbKey,
@@ -93,7 +93,7 @@ fileDesc =
 yamlFileDesc :: YAMLFileDescription
 yamlFileDesc =
   YAMLFileDescription
-    { party = FPRecipient,
+    { party = FRecipient,
       size = "26mb",
       chunkSize = "8mb",
       digest = FileDigest "abc",
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index a5046d47b..0cabdd123 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -51,14 +51,14 @@ testXFTPAgentReceive = withXFTPServer $ do
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
   runRight_ $ do
-    fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
     fId <- xftpReceiveFile rcp 1 fd recipientFiles
     ("", fId', RFDONE path) <- rfGet rcp
     liftIO $ do
       fId' `shouldBe` fId
       LB.readFile path `shouldReturn` file
 
-getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FPRecipient)
+getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
 getFileDescription path = do
   fd :: AFileDescription <- ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> LB.readFile path
   vfd <- liftEither . first INTERNAL $ validateFileDescription fd
@@ -89,7 +89,7 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
   -- receive file using agent - should not succeed due to server being down
   rcp <- getSMPAgentClient agentCfg initAgentServers
   fId <- runRight $ do
-    fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
     fId <- xftpReceiveFile rcp 1 fd recipientFiles
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
@@ -130,7 +130,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
   -- receive file using agent - should not succeed due to server being down
   rcp <- getSMPAgentClient agentCfg initAgentServers
   fId <- runRight $ do
-    fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
     fId <- xftpReceiveFile rcp 1 fd recipientFiles
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
@@ -171,7 +171,7 @@ testXFTPAgentSendExperimental = do
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
   runRight_ $ do
-    fd :: ValidFileDescription 'FPRecipient <- getFileDescription fdRcv
+    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
     rfId <- xftpReceiveFile rcp 1 fd recipientFiles
     ("", rfId', RFDONE path) <- rfGet rcp
     liftIO $ do

From ddc2da8fe44f95928213522ec43a40154fd3c050 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Mon, 13 Mar 2023 09:04:23 +0000
Subject: [PATCH 61/71] xftp: agent API for xftp commands and events (#684)

* xftp: agent API for xftp commands and events

* fix tests

* fix tests 2

* xftp: update agent send api

* update API to make temp path optional

* revert tmp path changes (fixes send)

---------

Co-authored-by: spacedandy <8711996+spaced4ndy@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Agent.hs         |  57 +++++-----
 src/Simplex/FileTransfer/Client/Main.hs   |   7 +-
 src/Simplex/FileTransfer/Description.hs   |  15 +++
 src/Simplex/Messaging/Agent.hs            |   6 +-
 src/Simplex/Messaging/Agent/Client.hs     |   4 +-
 src/Simplex/Messaging/Agent/Env/SQLite.hs |   1 -
 src/Simplex/Messaging/Agent/Lock.hs       |   2 +-
 src/Simplex/Messaging/Agent/Protocol.hs   |  52 ++++++---
 src/Simplex/Messaging/Agent/Store.hs      |   2 -
 src/Simplex/Messaging/Agent/TRcvQueues.hs |   4 +-
 tests/AgentTests.hs                       |  54 ++++++---
 tests/AgentTests/FunctionalAPITests.hs    | 128 ++++++++++++----------
 tests/AgentTests/NotificationTests.hs     |  10 +-
 tests/SMPAgentClient.hs                   |   1 -
 tests/XFTPAgent.hs                        |  47 ++++----
 15 files changed, 218 insertions(+), 172 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index b8847cdbf..54a266608 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -29,6 +29,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.List (isSuffixOf, partition)
@@ -36,7 +37,7 @@ import Data.List.NonEmpty (nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Simplex.FileTransfer.Client.Main (CLIError, SendOptions (..), cliSendFile)
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import Simplex.FileTransfer.Types
 import Simplex.FileTransfer.Util (removePath, uniqueCombine)
@@ -44,25 +45,26 @@ 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
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (tshow)
+import Simplex.Messaging.Util (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 -> FilePath -> m RcvFileId
-receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpPath = do
+receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId
+receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath = do
   g <- asks idsDrg
-  encPath <- uniqueCombine xftpPath "xftp.encrypted"
+  workPath <- maybe getTemporaryDirectory pure xftpWorkPath
+  encPath <- uniqueCombine workPath "xftp.encrypted"
   createDirectory encPath
-  fId <- withStore c $ \db -> createRcvFile db g userId fd xftpPath encPath
+  fId <- withStore c $ \db -> createRcvFile db g userId fd workPath encPath
   forM_ chunks downloadChunk
   pure fId
   where
@@ -186,9 +188,10 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
           pure $ path : ps
         getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
           throwError $ INTERNAL "no chunk path"
+        -- TODO refactor with decrypt in CLI, streaming decryption
         decrypt :: Int64 -> [FilePath] -> m FilePath
         decrypt encSize chunkPaths = do
-          lazyChunks <- readChunks chunkPaths
+          lazyChunks <- liftIO $ readChunks chunkPaths
           (authOk, f) <- liftEither . first cryptoError $ LC.sbDecryptTailTag key nonce (encSize - authTagSize) lazyChunks
           let (fileHdr, f') = LB.splitAt 1024 f
           -- withFile encPath ReadMode $ \r -> do
@@ -205,30 +208,25 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
                 removeFile path
                 throwError $ INTERNAL "Error decrypting file: incorrect auth tag"
               pure path
-        readChunks :: [FilePath] -> m LB.ByteString
-        readChunks =
-          foldM
-            ( \s path -> do
-                chunk <- liftIO $ LB.readFile path
-                pure $ s <> chunk
-            )
-            LB.empty
+        readChunks :: [FilePath] -> IO LB.ByteString
+        readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
 
-sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId
-sendFileExperimental AgentClient {subQ} _userId numRecipients xftpPath filePath = do
+sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId
+sendFileExperimental AgentClient {subQ} _userId filePath numRecipients xftpWorkPath = do
   g <- asks idsDrg
-  sndFileEntityId <- liftIO $ randomId g 12
-  void $ forkIO $ sendCLI sndFileEntityId
-  pure sndFileEntityId
+  sndFileId <- liftIO $ randomId g 12
+  void $ forkIO $ sendCLI sndFileId
+  pure sndFileId
   where
     randomId :: TVar ChaChaDRG -> Int -> IO ByteString
     randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
     sendCLI :: SndFileId -> m ()
-    sendCLI sndFileEntityId = do
+    sendCLI sndFileId = do
       let fileName = takeFileName filePath
-      outputDir <- uniqueCombine xftpPath (fileName <> ".descr")
+      workPath <- maybe getTemporaryDirectory pure xftpWorkPath
+      outputDir <- uniqueCombine workPath $ fileName <> ".descr"
       createDirectory outputDir
-      let tempPath = xftpPath </> "snd"
+      let tempPath = workPath </> "snd"
       createDirectoryIfMissing False tempPath
       let sendOptions =
             SendOptions
@@ -242,20 +240,21 @@ sendFileExperimental AgentClient {subQ} _userId numRecipients xftpPath filePath
               }
       liftCLI $ cliSendFile sendOptions
       (sndDescr, rcvDescrs) <- readDescrs outputDir fileName
-      notify sndFileEntityId $ SFDONE sndDescr rcvDescrs
+      notify sndFileId $ SFDONE sndDescr rcvDescrs
     liftCLI :: ExceptT CLIError IO () -> m ()
     liftCLI = either (throwError . INTERNAL . show) pure <=< liftIO . runExceptT
-    readDescrs :: FilePath -> FilePath -> m (String, [String])
+    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
-      -- TODO map files to contents
-      pure (sdFile, 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 sndFileEntityId cmd = atomically $ writeTBQueue subQ ("", sndFileEntityId, APC (sAEntity @e) cmd)
+    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
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 1c0e30574..6ac46ae61 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -458,7 +458,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
             throwError $ CLIError "Error decrypting file: incorrect auth tag"
           pure path
     readChunks :: [FilePath] -> IO LB.ByteString
-    readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) LB.empty
+    readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
     {-# NOINLINE readChunks #-}
     getFilePath :: String -> ExceptT CLIError IO FilePath
     getFilePath name =
@@ -523,9 +523,8 @@ strEnc :: StrEncoding a => a -> String
 strEnc = B.unpack . strEncode
 
 getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription
-getFileDescription path = do
-  fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
-  liftEither . first CLIError $ validateFileDescription fd
+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 =
diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs
index f9bb5c52d..c995f0dcd 100644
--- a/src/Simplex/FileTransfer/Description.hs
+++ b/src/Simplex/FileTransfer/Description.hs
@@ -27,6 +27,7 @@ module Simplex.FileTransfer.Description
     validateFileDescription,
     groupReplicasByServer,
     replicaServer,
+    fdSeparator,
     kb,
     mb,
     gb,
@@ -75,6 +76,7 @@ data FileDescription (p :: FileParty) = FileDescription
 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
@@ -83,6 +85,9 @@ pattern ValidFileDescription fd = ValidFD fd
 
 data AValidFileDescription = forall p. FilePartyI p => AVFD (ValidFileDescription p)
 
+fdSeparator :: IsString s => s
+fdSeparator = "################################\n"
+
 newtype FileDigest = FileDigest {unFileDigest :: ByteString}
   deriving (Eq, Show)
 
@@ -170,6 +175,16 @@ data FileServerReplica = FileServerReplica
   }
   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)
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index e615d76c8..15ba9fb67 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -339,12 +339,12 @@ toggleConnectionNtfs :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m
 toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c
 
 -- | Receive XFTP file
-xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> FilePath -> m RcvFileId
+xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId
 xftpReceiveFile c = withAgentEnv c .:. receiveFile c
 
 -- | Send XFTP file
-xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId
-xftpSendFile c userId n xftpPath filePath = withAgentEnv c $ sendFileExperimental c userId n xftpPath filePath
+xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId
+xftpSendFile c = withAgentEnv c .:: sendFileExperimental c
 
 -- | Activate operations
 activateAgent :: AgentErrorMonad m => AgentClient -> m ()
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 7ceaedcf4..8e8f2fe90 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -441,8 +441,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 'AEConn -> IO ()
-    notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn 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
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index 632b89961..e1263b90d 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -44,7 +44,6 @@ import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConf
 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
diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs
index 06b8a9efd..e0dd22713 100644
--- a/src/Simplex/Messaging/Agent/Lock.hs
+++ b/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)
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 9fd41da6a..7d7d1180b 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -104,6 +104,7 @@ module Simplex.Messaging.Agent.Protocol
     MsgIntegrity (..),
     MsgErrorType (..),
     QueueStatus (..),
+    UserId,
     ACorrId,
     AgentMsgId,
     NotificationsMode (..),
@@ -163,7 +164,8 @@ import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
-import Simplex.FileTransfer.Protocol (XFTPErrorType)
+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)
@@ -224,6 +226,8 @@ type ATransmission p = (ACorrId, EntityId, APartyCmd p)
 -- | SMP agent protocol transmission or transmission error.
 type ATransmissionOrError p = (ACorrId, EntityId, Either AgentErrorType (APartyCmd p))
 
+type UserId = Int64
+
 type ACorrId = ByteString
 
 -- | SMP agent protocol participants.
@@ -311,8 +315,8 @@ data ACommand (p :: AParty) (e :: AEntity) where
   END :: ACommand Agent AEConn
   CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
   DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
-  DOWN :: SMPServer -> [ConnId] -> ACommand Agent AEConn
-  UP :: SMPServer -> [ConnId] -> ACommand Agent AEConn
+  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
@@ -335,7 +339,8 @@ data ACommand (p :: AParty) (e :: AEntity) where
   RFPROG :: Int -> Int -> ACommand Agent AERcvFile
   RFDONE :: FilePath -> ACommand Agent AERcvFile
   RFERR :: AgentErrorType -> ACommand Agent AERcvFile
-  SFDONE :: String -> [String] -> ACommand Agent AESndFile
+  SFPROG :: Int -> Int -> ACommand Agent AESndFile
+  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile
 
 deriving instance Eq (ACommand p e)
 
@@ -367,8 +372,8 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   END_ :: ACommandTag Agent AEConn
   CONNECT_ :: ACommandTag Agent AENone
   DISCONNECT_ :: ACommandTag Agent AENone
-  DOWN_ :: ACommandTag Agent AEConn
-  UP_ :: ACommandTag Agent AEConn
+  DOWN_ :: ACommandTag Agent AENone
+  UP_ :: ACommandTag Agent AENone
   SWITCH_ :: ACommandTag Agent AEConn
   SEND_ :: ACommandTag Client AEConn
   MID_ :: ACommandTag Agent AEConn
@@ -391,6 +396,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   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)
@@ -439,6 +445,7 @@ aCommandTag = \case
   RFPROG {} -> RFPROG_
   RFDONE {} -> RFDONE_
   RFERR {} -> RFERR_
+  SFPROG {} -> SFPROG_
   SFDONE {} -> SFDONE_
 
 data QueueDirection = QDRcv | QDSnd
@@ -1305,10 +1312,10 @@ instance StrEncoding ACmdTag where
       "CON" -> ct CON_
       "SUB" -> t SUB_
       "END" -> ct END_
-      "CONNECT" -> at SAENone CONNECT_
-      "DISCONNECT" -> at SAENone DISCONNECT_
-      "DOWN" -> ct DOWN_
-      "UP" -> ct UP_
+      "CONNECT" -> nt CONNECT_
+      "DISCONNECT" -> nt DISCONNECT_
+      "DOWN" -> nt DOWN_
+      "UP" -> nt UP_
       "SWITCH" -> ct SWITCH_
       "SEND" -> t SEND_
       "MID" -> ct MID_
@@ -1321,20 +1328,23 @@ instance StrEncoding ACmdTag where
       "DEL" -> t DEL_
       "DEL_RCVQ" -> ct DEL_RCVQ_
       "DEL_CONN" -> ct DEL_CONN_
-      "DEL_USER" -> at SAENone DEL_USER_
+      "DEL_USER" -> nt DEL_USER_
       "CHK" -> t CHK_
       "STAT" -> ct STAT_
       "OK" -> ct OK_
       "ERR" -> ct ERR_
-      "SUSPENDED" -> at SAENone SUSPENDED_
+      "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 (APartyCmdTag p) where
   strEncode (APCT _ cmd) = strEncode cmd
@@ -1379,6 +1389,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     RFPROG_ -> "RFPROG"
     RFDONE_ -> "RFDONE"
     RFERR_ -> "RFERR"
+    SFPROG_ -> "SFPROG"
     SFDONE_ -> "SFDONE"
   strP = (\(APCT _ t) -> checkEntity t) <$?> strP
 
@@ -1438,14 +1449,19 @@ commandP binaryP =
           RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
           RFDONE_ -> s (RFDONE <$> strP)
           RFERR_ -> s (RFERR <$> strP)
-          SFDONE_ -> s (SFDONE <$> strP <*> rcvDescrs)
+          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 ','
-    rcvDescrs :: Parser [String]
-    rcvDescrs = strP `A.sepBy'` A.char ',' -- TODO consider separator
+    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
@@ -1497,7 +1513,8 @@ serializeCommand = \case
   RFPROG rcvd total -> s (RFPROG_, rcvd, total)
   RFDONE fPath -> s (RFDONE_, fPath)
   RFERR e -> s (RFERR_, e)
-  SFDONE sd rds -> B.unwords [s SFDONE_, s sd, rcvDescrs rds]
+  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
@@ -1505,8 +1522,7 @@ serializeCommand = \case
     showTs = B.pack . formatISO8601Millis
     connections :: [ConnId] -> ByteString
     connections = B.intercalate "," . map strEncode
-    rcvDescrs :: [String] -> ByteString
-    rcvDescrs = B.intercalate "," . map strEncode -- TODO consider separator
+    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
diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs
index ab6e66820..cf139c96b 100644
--- a/src/Simplex/Messaging/Agent/Store.hs
+++ b/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"
diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs
index aad0f16e6..bc116c2e3 100644
--- a/src/Simplex/Messaging/Agent/TRcvQueues.hs
+++ b/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
diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs
index 43eb0c132..6023ae398 100644
--- a/tests/AgentTests.hs
+++ b/tests/AgentTests.hs
@@ -92,19 +92,31 @@ tGetAgent = tGetAgent'
 
 tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e)
 tGetAgent' h = do
-  (corrId, connId, cmdOrErr) <- tGet SAgent h
+  (corrId, connId, cmdOrErr) <- pGetAgent h
   case cmdOrErr of
-    Right (APC _ CONNECT {}) -> tGetAgent' h
-    Right (APC _ DISCONNECT {}) -> tGetAgent' h
     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 (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 (AEntityTransmissionOrError 'Agent 'AEConn)
 h #: t = tPutRaw h t >> (<#:) h
@@ -119,7 +131,7 @@ action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right c
 (=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
 action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)
 
-correctTransmission :: AEntityTransmissionOrError p e -> AEntityTransmission p e
+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
@@ -128,10 +140,16 @@ correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
 (<#) :: 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 -> (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` ()
@@ -141,7 +159,7 @@ h #:# err = tryGet `shouldReturn` ()
         Just _ -> error err
         _ -> return ()
 
-pattern Msg :: MsgBody -> ACommand 'Agent 'AEConn
+pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
@@ -300,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
 
@@ -314,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)
 
@@ -337,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"
@@ -348,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)
@@ -380,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"
@@ -393,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
diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs
index c4adaabaf..8ef94eced 100644
--- a/tests/AgentTests/FunctionalAPITests.hs
+++ b/tests/AgentTests/FunctionalAPITests.hs
@@ -23,6 +23,7 @@ module AgentTests.FunctionalAPITests
     get',
     rfGet,
     sfGet,
+    nGet,
     (##>),
     (=##>),
     pattern Msg,
@@ -49,7 +50,6 @@ 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
@@ -68,7 +68,7 @@ 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 (AEntityTransmission e) -> (AEntityTransmission e -> 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 (AEntityTransmission 'AEConn)
@@ -80,17 +80,25 @@ 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) <- atomically (readTBQueue $ subQ c)
-  case cmd of
-    CONNECT {} -> get' c
-    DISCONNECT {} -> get' c
-    _ -> case testEquality e (sAEntity @e) of
-      Just Refl -> pure (corrId, connId, cmd)
-      _ -> error $ "unexpected command " <> show cmd
+  (corrId, connId, APC e cmd) <- pGet c
+  case testEquality e (sAEntity @e) of
+    Just Refl -> pure (corrId, connId, cmd)
+    _ -> error $ "unexpected command " <> show cmd
 
-pattern Msg :: MsgBody -> ACommand 'Agent 'AEConn
+pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent)
+pGet c = do
+  t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c)
+  case cmd of
+    CONNECT {} -> pGet c
+    DISCONNECT {} -> pGet c
+    _ -> pure t
+
+pattern Msg :: MsgBody -> ACommand 'Agent e
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 smpCfgV1 :: ProtocolClientConfig
@@ -405,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]
@@ -457,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
@@ -502,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
@@ -528,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 ()
@@ -562,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_ @AgentErrorType $ 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' @'AENone b
+    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
@@ -594,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' @'AENone b
+    ("", "", SUSPENDED) <- nGet b
     pure ()
 
 testBatchedSubscriptions :: ATransport -> IO ()
@@ -614,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
@@ -795,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' @'AENone 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"
 
@@ -824,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' @'AENone 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 ()
@@ -979,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
@@ -988,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]
@@ -1003,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'
@@ -1015,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'
diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs
index a3abd2242..490873b9e 100644
--- a/tests/AgentTests/NotificationTests.hs
+++ b/tests/AgentTests/NotificationTests.hs
@@ -9,7 +9,7 @@
 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
@@ -466,12 +466,12 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     pure (aliceId, bobId)
 
   runRight_ @AgentErrorType $ do
-    get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
-    get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+    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)
diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs
index cc80cb098..053f973e7 100644
--- a/tests/SMPAgentClient.hs
+++ b/tests/SMPAgentClient.hs
@@ -29,7 +29,6 @@ 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, XFTPServer)
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 0cabdd123..3d6406c14 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -9,12 +9,10 @@ import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Data.Bifunctor (first)
-import qualified Data.ByteString as LB
-import Data.List.NonEmpty (nonEmpty)
-import qualified Data.List.NonEmpty as L
+import qualified Data.ByteString.Char8 as B
 import SMPAgentClient (agentCfg, initAgentServers)
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), checkParty)
+import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpReceiveFile, xftpSendFile)
 import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
@@ -37,7 +35,7 @@ testXFTPAgentReceive = withXFTPServer $ do
   -- send file using CLI
   let filePath = senderFiles </> "testfile"
   xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
-  file <- LB.readFile filePath
+  file <- B.readFile filePath
   getFileSize filePath `shouldReturn` mb 17
   let fdRcv = filePath <> ".xftp" </> "rcv1.xftp"
       fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
@@ -52,18 +50,15 @@ testXFTPAgentReceive = withXFTPServer $ do
   rcp <- getSMPAgentClient agentCfg initAgentServers
   runRight_ $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd recipientFiles
+    fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles
     ("", fId', RFDONE path) <- rfGet rcp
     liftIO $ do
       fId' `shouldBe` fId
-      LB.readFile path `shouldReturn` file
+      B.readFile path `shouldReturn` file
 
 getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
-getFileDescription path = do
-  fd :: AFileDescription <- ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> LB.readFile path
-  vfd <- liftEither . first INTERNAL $ validateFileDescription fd
-  case vfd of
-    AVFD fd' -> either (throwError . INTERNAL) pure $ checkParty fd'
+getFileDescription path =
+  ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
 
 logCfgNoLogs :: LogConfig
 logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
@@ -90,7 +85,7 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
   rcp <- getSMPAgentClient agentCfg initAgentServers
   fId <- runRight $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd recipientFiles
+    fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
   disconnectAgentClient rcp
@@ -103,8 +98,8 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
     ("", fId', RFDONE path) <- rfGet rcp'
     liftIO $ do
       fId' `shouldBe` fId
-      file <- LB.readFile filePath
-      LB.readFile path `shouldReturn` file
+      file <- B.readFile filePath
+      B.readFile path `shouldReturn` file
 
   -- tmp path should be removed after receiving file
   doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
@@ -131,7 +126,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
   rcp <- getSMPAgentClient agentCfg initAgentServers
   fId <- runRight $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd recipientFiles
+    fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
   disconnectAgentClient rcp
@@ -153,27 +148,27 @@ testXFTPAgentSendExperimental = do
   -- create random file using cli
   let filePath = senderFiles </> "testfile"
   xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
-  file <- LB.readFile filePath
+  file <- B.readFile filePath
   getFileSize filePath `shouldReturn` mb 17
 
   -- send file using experimental agent API
   sndr <- getSMPAgentClient agentCfg initAgentServers
-  rcvDescrs <- runRight $ do
-    sfId <- xftpSendFile sndr 1 2 senderFiles filePath
+  rfd <- runRight $ do
+    sfId <- xftpSendFile sndr 1 filePath 2 $ Just senderFiles
     ("", sfId', SFDONE sndDescr rcvDescrs) <- sfGet sndr
     liftIO $ do
       sfId' `shouldBe` sfId
-      sndDescr `shouldBe` senderFiles </> "testfile.descr/testfile.xftp/snd.xftp.private"
-      rcvDescrs `shouldBe` [senderFiles </> "testfile.descr/testfile.xftp/rcv1.xftp", senderFiles </> "testfile.descr/testfile.xftp/rcv2.xftp"]
-    pure rcvDescrs
-  let fdRcv = maybe "" L.head (nonEmpty rcvDescrs)
+      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 `shouldBe` [rfd1, rfd2]
+      pure rfd1
 
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
   runRight_ $ do
-    fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    rfId <- xftpReceiveFile rcp 1 fd recipientFiles
+    rfId <- xftpReceiveFile rcp 1 rfd $ Just recipientFiles
     ("", rfId', RFDONE path) <- rfGet rcp
     liftIO $ do
       rfId' `shouldBe` rfId
-      LB.readFile path `shouldReturn` file
+      B.readFile path `shouldReturn` file

From db120b6d2eee04836a132f0bfbca9491cacf3dc8 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Tue, 14 Mar 2023 19:16:25 +0400
Subject: [PATCH 62/71] xftp: pass save path to agent (#685)

---
 package.yaml                                  |  1 +
 simplexmq.cabal                               |  1 +
 src/Simplex/FileTransfer/Agent.hs             | 36 ++++++++++---------
 src/Simplex/FileTransfer/Client.hs            |  2 +-
 src/Simplex/FileTransfer/Types.hs             |  3 +-
 src/Simplex/Messaging/Agent.hs                |  4 +--
 src/Simplex/Messaging/Agent/Protocol.hs       |  8 ++---
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 26 ++++++--------
 .../SQLite/Migrations/M20230223_files.hs      |  3 +-
 .../Store/SQLite/Migrations/agent_schema.sql  |  3 +-
 tests/AgentTests/SchemaDump.hs                |  3 +-
 tests/XFTPAgent.hs                            | 32 +++++++++++------
 12 files changed, 65 insertions(+), 57 deletions(-)

diff --git a/package.yaml b/package.yaml
index 86e2d70be..eb10dac51 100644
--- a/package.yaml
+++ b/package.yaml
@@ -135,6 +135,7 @@ tests:
     main: Test.hs
     dependencies:
       - simplexmq
+      - deepseq == 1.4.*
       - hspec == 2.7.*
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
diff --git a/simplexmq.cabal b/simplexmq.cabal
index 422ea01e8..dad233141 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -554,6 +554,7 @@ test-suite simplexmq-test
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 54a266608..b485f2844 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -58,13 +58,13 @@ import UnliftIO.Concurrent
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 
-receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId
-receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath = do
+receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> FilePath -> m RcvFileId
+receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath savePath = do
   g <- asks idsDrg
   workPath <- maybe getTemporaryDirectory pure xftpWorkPath
   encPath <- uniqueCombine workPath "xftp.encrypted"
   createDirectory encPath
-  fId <- withStore c $ \db -> createRcvFile db g userId fd workPath encPath
+  fId <- withStore c $ \db -> createRcvFile db g userId fd encPath savePath
   forM_ chunks downloadChunk
   pure fId
   where
@@ -167,18 +167,22 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
           decryptFile f `catchError` (workerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
     decryptFile :: RcvFile -> m ()
-    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveDir, savePath, chunks} = do
-      forM_ savePath $ \p -> do
-        removePath p
-        withStore' c (`updateRcvFileNoSavePath` rcvFileId)
+    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, chunks} = do
+      -- TODO test; recreate file if it's in status RFSDecrypting
+      -- when (status == RFSDecrypting) $
+      --   whenM (doesFileExist savePath) (removeFile savePath >> emptyFile)
       withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
       chunkPaths <- getChunkPaths chunks
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
-      path <- decrypt encSize chunkPaths
+      decrypt encSize chunkPaths
       forM_ tmpPath removePath
-      withStore' c $ \db -> updateRcvFileComplete db rcvFileId path
-      notify $ RFDONE path
+      withStore' c (`updateRcvFileComplete` rcvFileId)
+      notify RFDONE
       where
+        -- emptyFile :: m ()
+        -- emptyFile = do
+        --   h <- openFile savePath AppendMode
+        --   liftIO $ B.hPut h "" >> hFlush h
         notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
         notify cmd = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC (sAEntity @e) cmd)
         getChunkPaths :: [RcvFileChunk] -> m [FilePath]
@@ -189,7 +193,7 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
         getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
           throwError $ INTERNAL "no chunk path"
         -- TODO refactor with decrypt in CLI, streaming decryption
-        decrypt :: Int64 -> [FilePath] -> m FilePath
+        decrypt :: Int64 -> [FilePath] -> m ()
         decrypt encSize chunkPaths = do
           lazyChunks <- liftIO $ readChunks chunkPaths
           (authOk, f) <- liftEither . first cryptoError $ LC.sbDecryptTailTag key nonce (encSize - authTagSize) lazyChunks
@@ -200,14 +204,12 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
             -- TODO XFTP errors
             A.Fail _ _ e -> throwError $ INTERNAL $ "Invalid file header: " <> e
             A.Partial _ -> throwError $ INTERNAL "Invalid file header"
-            A.Done rest FileHeader {fileName} -> do
-              -- TODO touch file in agent bracket
-              path <- uniqueCombine saveDir fileName
-              liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
+            A.Done rest FileHeader {fileName = _fn} -> do
+              -- ? check file name match
+              liftIO $ LB.writeFile savePath $ LB.fromStrict rest <> f'
               unless authOk $ do
-                removeFile path
+                removeFile savePath
                 throwError $ INTERNAL "Error decrypting file: incorrect auth tag"
-              pure path
         readChunks :: [FilePath] -> IO LB.ByteString
         readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
 
diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs
index d46971d64..a98248c03 100644
--- a/src/Simplex/FileTransfer/Client.hs
+++ b/src/Simplex/FileTransfer/Client.hs
@@ -174,7 +174,7 @@ downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChu
 downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do
   (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
   sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
-    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead = _bg, bodySize = _bs, bodyPart}) -> case bodyPart of
       -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
       Just chunkPart -> do
         let dhSecret = C.dh' sDhKey rpDhKey
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index da673f4c9..c9f5aa7ae 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -47,8 +47,7 @@ data RcvFile = RcvFile
     chunkSize :: FileSize Word32,
     chunks :: [RcvFileChunk],
     tmpPath :: Maybe FilePath,
-    saveDir :: FilePath,
-    savePath :: Maybe FilePath,
+    savePath :: FilePath,
     status :: RcvFileStatus
   }
   deriving (Eq, Show)
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 15ba9fb67..a1d80b93f 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -339,8 +339,8 @@ toggleConnectionNtfs :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m
 toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c
 
 -- | Receive XFTP file
-xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId
-xftpReceiveFile c = withAgentEnv c .:. receiveFile c
+xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> FilePath -> m RcvFileId
+xftpReceiveFile c = withAgentEnv c .:: receiveFile c
 
 -- | Send XFTP file
 xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 7d7d1180b..77b1c4ccf 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -337,7 +337,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   SUSPENDED :: ACommand Agent AENone
   -- XFTP commands and responses
   RFPROG :: Int -> Int -> ACommand Agent AERcvFile
-  RFDONE :: FilePath -> ACommand Agent AERcvFile
+  RFDONE :: ACommand Agent AERcvFile
   RFERR :: AgentErrorType -> ACommand Agent AERcvFile
   SFPROG :: Int -> Int -> ACommand Agent AESndFile
   SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile
@@ -443,7 +443,7 @@ aCommandTag = \case
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
   RFPROG {} -> RFPROG_
-  RFDONE {} -> RFDONE_
+  RFDONE -> RFDONE_
   RFERR {} -> RFERR_
   SFPROG {} -> SFPROG_
   SFDONE {} -> SFDONE_
@@ -1447,7 +1447,7 @@ commandP binaryP =
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
           RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
-          RFDONE_ -> s (RFDONE <$> strP)
+          RFDONE_ -> pure RFDONE
           RFERR_ -> s (RFERR <$> strP)
           SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal)
           SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP)
@@ -1511,7 +1511,7 @@ serializeCommand = \case
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
   RFPROG rcvd total -> s (RFPROG_, rcvd, total)
-  RFDONE fPath -> s (RFDONE_, fPath)
+  RFDONE -> s RFDONE_
   RFERR e -> s (RFERR_, e)
   SFPROG sent total -> s (SFPROG_, sent, total)
   SFDONE sd rds -> B.unwords [s SFDONE_, serializeBinary (sfDone sd rds)]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 9d5e5e14e..9252682c2 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -132,7 +132,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateRcvFileStatus,
     updateRcvFileError,
     updateRcvFileComplete,
-    updateRcvFileNoSavePath,
     updateRcvFileNoTmpPath,
     getNextRcvChunkToDownload,
     getNextRcvFileToDecrypt,
@@ -1739,7 +1738,7 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do
     DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash)
 
 createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> IO (Either StoreError RcvFileId)
-createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = runExceptT $ do
+createRcvFile db gVar userId fd@FileDescription {chunks} tmpPath savePath = runExceptT $ do
   (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd
   liftIO $
     forM_ chunks $ \fc@FileChunk {replicas} -> do
@@ -1753,8 +1752,8 @@ createRcvFile db gVar userId fd@FileDescription {chunks} saveDir tmpPath = runEx
         createWithRandomId gVar $ \rcvFileEntityId ->
           DB.execute
             db
-            "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, status) VALUES (?,?,?,?,?,?,?,?,?,?)"
-            (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, RFSReceiving)
+            "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_path, status) VALUES (?,?,?,?,?,?,?,?,?,?)"
+            (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, RFSReceiving)
       rcvFileId <- liftIO $ insertedRowId db
       pure (rcvFileEntityId, rcvFileId)
     insertChunk :: FileChunk -> DBRcvFileId -> IO Int64
@@ -1784,15 +1783,15 @@ getRcvFile db rcvFileId = runExceptT $ do
         DB.query
           db
           [sql|
-            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_dir, save_path, status
+            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_path, status
             FROM rcv_files
             WHERE rcv_file_id = ?
           |]
           (Only rcvFileId)
       where
-        toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, Maybe FilePath, RcvFileStatus) -> RcvFile
-        toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status) =
-          RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, saveDir, savePath, status, chunks = []}
+        toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, Maybe FilePath, FilePath, RcvFileStatus) -> RcvFile
+        toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, status) =
+          RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, status, chunks = []}
     getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk]
     getChunks rcvFileEntityId userId fileTmpPath = do
       chunks <-
@@ -1859,15 +1858,10 @@ updateRcvFileError db rcvFileId errStr = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE rcv_files SET tmp_path = NULL, error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId)
 
-updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> FilePath -> IO ()
-updateRcvFileComplete db rcvFileId savePath = do
+updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> IO ()
+updateRcvFileComplete db rcvFileId = do
   updatedAt <- getCurrentTime
-  DB.execute db "UPDATE rcv_files SET tmp_path = NULL, save_path = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (savePath, RFSComplete, updatedAt, rcvFileId)
-
-updateRcvFileNoSavePath :: DB.Connection -> DBRcvFileId -> IO ()
-updateRcvFileNoSavePath db rcvFileId = do
-  updatedAt <- getCurrentTime
-  DB.execute db "UPDATE rcv_files SET save_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId)
+  DB.execute db "UPDATE rcv_files SET tmp_path = NULL, status = ?, updated_at = ? WHERE rcv_file_id = ?" (RFSComplete, updatedAt, rcvFileId)
 
 updateRcvFileNoTmpPath :: DB.Connection -> DBRcvFileId -> IO ()
 updateRcvFileNoTmpPath db rcvFileId = do
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index 2ad06b4c8..8853deb0e 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -28,8 +28,7 @@ CREATE TABLE rcv_files (
   nonce BLOB NOT NULL,
   chunk_size INTEGER NOT NULL,
   tmp_path TEXT,
-  save_dir TEXT NOT NULL,
-  save_path TEXT,
+  save_path TEXT NOT NULL,
   status TEXT NOT NULL,
   error TEXT,
   created_at TEXT NOT NULL DEFAULT (datetime('now')),
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index ee7850191..b09f5a97b 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -302,8 +302,7 @@ CREATE TABLE rcv_files(
   nonce BLOB NOT NULL,
   chunk_size INTEGER NOT NULL,
   tmp_path TEXT,
-  save_dir TEXT NOT NULL,
-  save_path TEXT,
+  save_path TEXT NOT NULL,
   status TEXT NOT NULL,
   error TEXT,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs
index 43c67a332..54ceb48ad 100644
--- a/tests/AgentTests/SchemaDump.hs
+++ b/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
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 3d6406c14..8e2d149bc 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -18,6 +18,7 @@ import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import System.Directory (doesDirectoryExist, getFileSize)
 import System.FilePath ((</>))
+import System.Process (readCreateProcess, shell)
 import System.Timeout (timeout)
 import Test.Hspec
 import XFTPCLI
@@ -48,13 +49,18 @@ testXFTPAgentReceive = withXFTPServer $ do
                ]
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
+  let savePath = recipientFiles </> "testfile"
+  run $ "touch " <> savePath
   runRight_ $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles
-    ("", fId', RFDONE path) <- rfGet rcp
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath
+    ("", fId', RFDONE) <- rfGet rcp
     liftIO $ do
       fId' `shouldBe` fId
-      B.readFile path `shouldReturn` file
+      B.readFile savePath `shouldReturn` file
+
+run :: String -> IO ()
+run cmd = void $ readCreateProcess (shell cmd) ""
 
 getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
 getFileDescription path =
@@ -82,10 +88,12 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
                  ]
 
   -- receive file using agent - should not succeed due to server being down
+  let savePath = recipientFiles </> "testfile"
+  run $ "touch " <> savePath
   rcp <- getSMPAgentClient agentCfg initAgentServers
   fId <- runRight $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
   disconnectAgentClient rcp
@@ -95,11 +103,11 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
   rcp' <- getSMPAgentClient agentCfg initAgentServers
   withXFTPServerStoreLogOn $ \_ -> do
     -- receive file using agent - should succeed with server up
-    ("", fId', RFDONE path) <- rfGet rcp'
+    ("", fId', RFDONE) <- rfGet rcp'
     liftIO $ do
       fId' `shouldBe` fId
       file <- B.readFile filePath
-      B.readFile path `shouldReturn` file
+      B.readFile savePath `shouldReturn` file
 
   -- tmp path should be removed after receiving file
   doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
@@ -124,9 +132,11 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
 
   -- receive file using agent - should not succeed due to server being down
   rcp <- getSMPAgentClient agentCfg initAgentServers
+  let savePath = recipientFiles </> "testfile"
+  run $ "touch " <> savePath
   fId <- runRight $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd $ Just recipientFiles
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
   disconnectAgentClient rcp
@@ -166,9 +176,11 @@ testXFTPAgentSendExperimental = do
 
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
+  let savePath = recipientFiles </> "testfile"
+  run $ "touch " <> savePath
   runRight_ $ do
-    rfId <- xftpReceiveFile rcp 1 rfd $ Just recipientFiles
-    ("", rfId', RFDONE path) <- rfGet rcp
+    rfId <- xftpReceiveFile rcp 1 rfd (Just recipientFiles) savePath
+    ("", rfId', RFDONE) <- rfGet rcp
     liftIO $ do
       rfId' `shouldBe` rfId
-      B.readFile path `shouldReturn` file
+      B.readFile savePath `shouldReturn` file

From a0eb53b891b1f4f765f440020654fbae45bf8b00 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Tue, 14 Mar 2023 22:56:19 +0000
Subject: [PATCH 63/71] xftp: use agent servers in experimental send, refactor
 decryption (#686)

* xftp: use agent servers in experimental send, refactor decryption

* fix/enable xftp send test test

* allow any order
---
 simplexmq.cabal                         |  1 +
 src/Simplex/FileTransfer/Agent.hs       | 43 ++++++-------------------
 src/Simplex/FileTransfer/Client/Main.hs | 33 +++++++------------
 src/Simplex/FileTransfer/Crypto.hs      | 42 ++++++++++++++++++++++++
 tests/SMPAgentClient.hs                 |  6 ++--
 tests/XFTPAgent.hs                      |  7 ++--
 6 files changed, 69 insertions(+), 63 deletions(-)
 create mode 100644 src/Simplex/FileTransfer/Crypto.hs

diff --git a/simplexmq.cabal b/simplexmq.cabal
index dad233141..cd0da9b3c 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -40,6 +40,7 @@ library
       Simplex.FileTransfer.Client.Agent
       Simplex.FileTransfer.Client.Main
       Simplex.FileTransfer.Client.Presets
+      Simplex.FileTransfer.Crypto
       Simplex.FileTransfer.Description
       Simplex.FileTransfer.Protocol
       Simplex.FileTransfer.Server
diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index b485f2844..a71026dcb 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -25,17 +25,15 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Int (Int64)
 import Data.List (isSuffixOf, partition)
 import Data.List.NonEmpty (nonEmpty)
 import qualified Data.List.NonEmpty as L
 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 (..))
@@ -46,12 +44,10 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.SQLite
-import qualified Simplex.Messaging.Crypto.Lazy as LC
-import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (XFTPServer)
+import Simplex.Messaging.Protocol (XFTPServer, XFTPServerWithAuth)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (liftIOEither, tshow)
+import Simplex.Messaging.Util (liftError, liftIOEither, tshow)
 import System.FilePath (takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Concurrent
@@ -174,7 +170,7 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
       withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
       chunkPaths <- getChunkPaths chunks
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
-      decrypt encSize chunkPaths
+      void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure savePath
       forM_ tmpPath removePath
       withStore' c (`updateRcvFileComplete` rcvFileId)
       notify RFDONE
@@ -192,38 +188,19 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
           pure $ path : ps
         getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
           throwError $ INTERNAL "no chunk path"
-        -- TODO refactor with decrypt in CLI, streaming decryption
-        decrypt :: Int64 -> [FilePath] -> m ()
-        decrypt encSize chunkPaths = do
-          lazyChunks <- liftIO $ readChunks chunkPaths
-          (authOk, f) <- liftEither . first cryptoError $ LC.sbDecryptTailTag key nonce (encSize - authTagSize) lazyChunks
-          let (fileHdr, f') = LB.splitAt 1024 f
-          -- withFile encPath ReadMode $ \r -> do
-          --   fileHdr <- liftIO $ B.hGet r 1024
-          case A.parse smpP $ LB.toStrict fileHdr of
-            -- TODO XFTP errors
-            A.Fail _ _ e -> throwError $ INTERNAL $ "Invalid file header: " <> e
-            A.Partial _ -> throwError $ INTERNAL "Invalid file header"
-            A.Done rest FileHeader {fileName = _fn} -> do
-              -- ? check file name match
-              liftIO $ LB.writeFile savePath $ LB.fromStrict rest <> f'
-              unless authOk $ do
-                removeFile savePath
-                throwError $ INTERNAL "Error decrypting file: incorrect auth tag"
-        readChunks :: [FilePath] -> IO LB.ByteString
-        readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
 
 sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId
-sendFileExperimental AgentClient {subQ} _userId filePath numRecipients xftpWorkPath = do
+sendFileExperimental AgentClient {subQ, xftpServers} userId filePath numRecipients xftpWorkPath = do
   g <- asks idsDrg
   sndFileId <- liftIO $ randomId g 12
-  void $ forkIO $ sendCLI sndFileId
+  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 -> m ()
-    sendCLI sndFileId = do
+    sendCLI :: SndFileId -> [XFTPServerWithAuth] -> m ()
+    sendCLI sndFileId xftpSrvs = do
       let fileName = takeFileName filePath
       workPath <- maybe getTemporaryDirectory pure xftpWorkPath
       outputDir <- uniqueCombine workPath $ fileName <> ".descr"
@@ -235,7 +212,7 @@ sendFileExperimental AgentClient {subQ} _userId filePath numRecipients xftpWorkP
               { filePath,
                 outputDir = Just outputDir,
                 numRecipients,
-                xftpServers = [],
+                xftpServers = xftpSrvs,
                 retryCount = 3,
                 tempPath = Just tempPath,
                 verbose = False
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 6ac46ae61..b2ef99be6 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -44,6 +44,7 @@ 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 (..))
@@ -88,6 +89,13 @@ fileSizeLen = 8
 newtype CLIError = CLIError String
   deriving (Eq, Show, Exception)
 
+cliCryptoError :: FTCryptoError -> CLIError
+cliCryptoError = \case
+  FTCEDecryptionError 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
@@ -420,7 +428,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       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 <- decryptFile encSize chunkPaths key nonce
+      path <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath
       forM_ chunks $ acknowledgeFileChunk a
       whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
       liftIO $ do
@@ -441,31 +449,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
         when verbose $ putStrLn ""
       pure (chunkNo, chunkPath)
     downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
-    decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
-    decryptFile encSize chunkPaths key nonce = do
-      (authOk, f) <- liftEither . first (CLIError . show) . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
-      let (fileHdr, f') = LB.splitAt 1024 f
-      -- withFile encPath ReadMode $ \r -> do
-      --   fileHdr <- liftIO $ B.hGet r 1024
-      case A.parse smpP $ LB.toStrict fileHdr of
-        A.Fail _ _ e -> throwError $ CLIError $ "Invalid file header: " <> e
-        A.Partial _ -> throwError $ CLIError "Invalid file header"
-        A.Done rest FileHeader {fileName} -> do
-          path <- getFilePath fileName
-          liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
-          unless authOk $ do
-            removeFile path
-            throwError $ CLIError "Error decrypting file: incorrect auth tag"
-          pure path
-    readChunks :: [FilePath] -> IO LB.ByteString
-    readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
-    {-# NOINLINE readChunks #-}
-    getFilePath :: String -> ExceptT CLIError IO FilePath
+    getFilePath :: String -> ExceptT String IO FilePath
     getFilePath name =
       case filePath of
         Just path ->
           ifM (doesDirectoryExist path) (uniqueCombine path name) $
-            ifM (doesFileExist path) (throwError $ CLIError "File already exists") (pure path)
+            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
diff --git a/src/Simplex/FileTransfer/Crypto.hs b/src/Simplex/FileTransfer/Crypto.hs
new file mode 100644
index 000000000..53fdb5856
--- /dev/null
+++ b/src/Simplex/FileTransfer/Crypto.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Crypto where
+
+import Control.Monad.Except
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+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 qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import UnliftIO.Directory (removeFile)
+
+decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath
+decryptChunks encSize chunkPaths key nonce getFilePath = do
+  (authOk, f) <- liftEither . first FTCEDecryptionError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
+  let (fileHdr, f') = LB.splitAt 1024 f
+  -- withFile encPath ReadMode $ \r -> do
+  --   fileHdr <- liftIO $ B.hGet r 1024
+  case A.parse smpP $ LB.toStrict fileHdr of
+    A.Fail _ _ e -> throwError $ FTCEInvalidHeader e
+    A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete"
+    A.Done rest FileHeader {fileName} -> do
+      path <- withExceptT FTCEFileIOError $ getFilePath fileName
+      liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
+      unless authOk $ do
+        removeFile path
+        throwError FTCEInvalidAuthTag
+      pure path
+
+readChunks :: [FilePath] -> IO LB.ByteString
+readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
+
+data FTCryptoError
+  = FTCEDecryptionError C.CryptoError
+  | FTCEInvalidHeader String
+  | FTCEInvalidAuthTag
+  | FTCEFileIOError String
+  deriving (Show, Eq)
diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs
index 053f973e7..bcb9d080a 100644
--- a/tests/SMPAgentClient.hs
+++ b/tests/SMPAgentClient.hs
@@ -31,12 +31,13 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth, XFTPServer)
+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"
@@ -173,9 +174,6 @@ testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:50
 testSMPServer2 :: SMPServer
 testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
 
-testXFTPServer :: XFTPServer
-testXFTPServer = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"
-
 initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index 8e2d149bc..db04e1d20 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -29,7 +29,7 @@ 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
-  xit "should send file using experimental api" testXFTPAgentSendExperimental -- TODO uses default servers (remote)
+  it "should send file using experimental api" testXFTPAgentSendExperimental -- TODO uses default servers (remote)
 
 testXFTPAgentReceive :: IO ()
 testXFTPAgentReceive = withXFTPServer $ do
@@ -153,8 +153,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
   doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
 
 testXFTPAgentSendExperimental :: IO ()
--- testXFTPAgentSendExperimental = withXFTPServer $ do
-testXFTPAgentSendExperimental = do
+testXFTPAgentSendExperimental = withXFTPServer $ do
   -- create random file using cli
   let filePath = senderFiles </> "testfile"
   xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -171,7 +170,7 @@ testXFTPAgentSendExperimental = do
       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 `shouldBe` [rfd1, rfd2]
+      rcvDescrs `shouldMatchList` [rfd1, rfd2]
       pure rfd1
 
   -- receive file using agent

From bab689099fcbeef2e8aadf885d9ce17e42ad6141 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Thu, 16 Mar 2023 13:57:21 +0000
Subject: [PATCH 64/71] xftp: streaming file encryption/decryption to avoid
 memory spikes (#687)

* xftp: streaming file decryption to avoid memory spikes

* refactor, enable tests

* streaming encryption

* refactor
---
 src/Simplex/FileTransfer/Client/Main.hs |  18 ++--
 src/Simplex/FileTransfer/Crypto.hs      | 107 ++++++++++++++++++++----
 src/Simplex/Messaging/Crypto/Lazy.hs    |  49 ++++++++---
 src/Simplex/Messaging/Util.hs           |   4 +
 4 files changed, 136 insertions(+), 42 deletions(-)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index b2ef99be6..5ed5d5eba 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -25,7 +25,6 @@ import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
 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 qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
@@ -91,7 +90,7 @@ newtype CLIError = CLIError String
 
 cliCryptoError :: FTCryptoError -> CLIError
 cliCryptoError = \case
-  FTCEDecryptionError e -> CLIError $ "Error decrypting file: " <> show e
+  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
@@ -261,7 +260,7 @@ 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) <- encryptFile fileName
+  (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName
   liftIO $ printNoNewLine "Uploading file..."
   uploadedChunks <- newTVarIO []
   sentChunks <- uploadFile chunkSpecs uploadedChunks encSize
@@ -276,8 +275,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
     putStrLn "Pass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
   where
-    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
-    encryptFile fileName = do
+    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"
@@ -289,20 +288,13 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
           defChunkSize = head chunkSizes
           chunkSizes' = map fromIntegral chunkSizes
           encSize = sum chunkSizes'
-      encrypt fileHdr key nonce fileSize' encSize encPath
+      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)
-      where
-        encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
-        encrypt fileHdr key nonce fileSize' encSize encFile = do
-          f <- liftIO $ LB.readFile filePath
-          let f' = LB.fromStrict fileHdr <> f
-          c <- liftEither $ first (CLIError . show) $ LC.sbEncryptTailTag key nonce f' fileSize' $ encSize - authTagSize
-          liftIO $ LB.writeFile encFile c
     uploadFile :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
     uploadFile chunks uploadedChunks encSize = do
       a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
diff --git a/src/Simplex/FileTransfer/Crypto.hs b/src/Simplex/FileTransfer/Crypto.hs
index 53fdb5856..71f5dec96 100644
--- a/src/Simplex/FileTransfer/Crypto.hs
+++ b/src/Simplex/FileTransfer/Crypto.hs
@@ -1,42 +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 encSize chunkPaths key nonce getFilePath = do
-  (authOk, f) <- liftEither . first FTCEDecryptionError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
-  let (fileHdr, f') = LB.splitAt 1024 f
-  -- withFile encPath ReadMode $ \r -> do
-  --   fileHdr <- liftIO $ B.hGet r 1024
-  case A.parse smpP $ LB.toStrict fileHdr of
-    A.Fail _ _ e -> throwError $ FTCEInvalidHeader e
-    A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete"
-    A.Done rest FileHeader {fileName} -> do
-      path <- withExceptT FTCEFileIOError $ getFilePath fileName
-      liftIO $ LB.writeFile path $ LB.fromStrict rest <> f'
-      unless authOk $ do
-        removeFile path
-        throwError FTCEInvalidAuthTag
-      pure path
+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
-  = FTCEDecryptionError C.CryptoError
+  = FTCECryptoError C.CryptoError
   | FTCEInvalidHeader String
   | FTCEInvalidAuthTag
   | FTCEFileIOError String
-  deriving (Show, Eq)
+  deriving (Show, Eq, Exception)
diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs
index db40a9fb9..ab972c8da 100644
--- a/src/Simplex/Messaging/Crypto/Lazy.hs
+++ b/src/Simplex/Messaging/Crypto/Lazy.hs
@@ -11,6 +11,7 @@ module Simplex.Messaging.Crypto.Lazy
     sha512Hash,
     pad,
     unPad,
+    splitLen,
     sbEncrypt,
     sbDecrypt,
     sbEncryptTailTag,
@@ -21,7 +22,10 @@ module Simplex.Messaging.Crypto.Lazy
     sbInit,
     sbEncryptChunk,
     sbDecryptChunk,
+    sbEncryptChunkLazy,
+    sbDecryptChunkLazy,
     sbAuth,
+    LazyByteString,
   )
 where
 
@@ -30,6 +34,7 @@ import qualified Crypto.Error as CE
 import Crypto.Hash (Digest, hashlazy)
 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
@@ -37,6 +42,7 @@ 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)
@@ -77,11 +83,14 @@ 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
@@ -111,9 +120,9 @@ sbDecrypt (SbKey key) (CbNonce nonce) packet
 secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString)
 secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
-    process state = foldlChunks update ([], state) msg
-    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
-    run state = let (cs, state') = process state in BA.convert (sbAuth state') :| reverse cs
+    run state =
+      let (!cs, !state') = secretBoxLazy_ sbProcess state msg
+       in BA.convert (sbAuth state') :| reverse cs
 
 -- | 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
@@ -135,9 +144,15 @@ sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet =
 secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
 secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
-    process state = foldlChunks update ([], state) msg
-    update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st')
-    run state = let (cs, state') = process state in reverse $ BA.convert (sbAuth state') : cs
+    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)
 
@@ -158,16 +173,26 @@ sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
     state1 = XSalsa.derive state0 iv1
     (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
+  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
+  let (!s, !st') = XSalsa.combine st chunk
+      !authSt' = Poly1305.update authSt chunk
    in (s, (st', authSt'))
 
 sbAuth :: SbState -> Poly1305.Auth
diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs
index 6e1b5ef11..a98175ff0 100644
--- a/src/Simplex/Messaging/Util.hs
+++ b/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 #-}

From 9255d48b6960efec2d8f63face4ed2ec0d13bc4e Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Thu, 16 Mar 2023 18:12:38 +0400
Subject: [PATCH 65/71] xftp: move delay to replica (#688)

---
 src/Simplex/FileTransfer/Agent.hs             |  9 ++--
 src/Simplex/FileTransfer/Client/Main.hs       |  1 -
 src/Simplex/FileTransfer/Types.hs             |  5 +--
 src/Simplex/Messaging/Agent.hs                |  1 -
 src/Simplex/Messaging/Agent/Client.hs         |  2 +-
 .../Messaging/Agent/NtfSubSupervisor.hs       |  1 -
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 42 ++++++++-----------
 .../SQLite/Migrations/M20230223_files.hs      |  3 +-
 .../Store/SQLite/Migrations/agent_schema.sql  |  3 +-
 src/Simplex/Messaging/Agent/TAsyncs.hs        |  1 -
 src/Simplex/Messaging/Notifications/Server.hs |  1 -
 src/Simplex/Messaging/Transport/Server.hs     |  1 -
 12 files changed, 25 insertions(+), 45 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index a71026dcb..6e4a84c7e 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -19,7 +19,6 @@ module Simplex.FileTransfer.Agent
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError)
 import Control.Monad
 import Control.Monad.Except
@@ -96,7 +95,7 @@ runXFTPWorker c srv doWork = do
       case nextChunk of
         Nothing -> noWorkToDo
         Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
-        Just fc@RcvFileChunk {rcvFileId, rcvFileEntityId, rcvChunkId, fileTmpPath, delay, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId} : _} -> do
+        Just fc@RcvFileChunk {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 ->
@@ -104,16 +103,14 @@ runXFTPWorker c srv doWork = do
               `catchError` retryOnError delay' loop (workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) . show)
           where
             retryOnError :: Int -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
-            retryOnError chunkDelay loop done e = do
+            retryOnError replicaDelay loop done e = do
               logError $ "XFTP worker error: " <> tshow e
               if temporaryAgentError e
                 then retryLoop
                 else done e
               where
                 retryLoop = do
-                  withStore' c $ \db -> do
-                    updateRcvFileChunkDelay db rcvChunkId chunkDelay
-                    increaseRcvChunkReplicaRetries db rcvChunkReplicaId
+                  withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
                   atomically $ endAgentOperation c AORcvNetwork
                   atomically $ throwWhenInactive c
                   atomically $ beginAgentOperation c AORcvNetwork
diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index 5ed5d5eba..ed626b4dd 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -18,7 +18,6 @@ module Simplex.FileTransfer.Client.Main
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index c9f5aa7ae..e71460fc2 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -89,8 +89,7 @@ data RcvFileChunk = RcvFileChunk
     digest :: FileDigest,
     replicas :: [RcvFileChunkReplica],
     fileTmpPath :: FilePath,
-    chunkTmpPath :: Maybe FilePath,
-    delay :: Maybe Int
+    chunkTmpPath :: Maybe FilePath
   }
   deriving (Eq, Show)
 
@@ -100,7 +99,7 @@ data RcvFileChunkReplica = RcvFileChunkReplica
     replicaId :: ChunkReplicaId,
     replicaKey :: C.APrivateSignKey,
     received :: Bool,
-    -- acknowledged :: Bool,
+    delay :: Maybe Int,
     retries :: Int
   }
   deriving (Eq, Show)
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index a1d80b93f..fcd68361c 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -92,7 +92,6 @@ module Simplex.Messaging.Agent
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo, showText)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 8e8f2fe90..89559329f 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -87,7 +87,7 @@ where
 import Control.Applicative ((<|>))
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (retry, stateTVar, throwSTM)
+import Control.Concurrent.STM (retry, throwSTM)
 import Control.Exception (AsyncException (..))
 import Control.Logger.Simple
 import Control.Monad.Except
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 459dc1206..4061335b7 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
@@ -18,7 +18,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
 where
 
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
 import Control.Monad.Except
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index 9252682c2..b8e02fc49 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -126,8 +126,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- File transfer
     createRcvFile,
     getRcvFile,
-    updateRcvFileChunkDelay,
-    increaseRcvChunkReplicaRetries,
+    updateRcvChunkReplicaDelay,
     updateRcvFileChunkReceived,
     updateRcvFileStatus,
     updateRcvFileError,
@@ -148,7 +147,6 @@ module Simplex.Messaging.Agent.Store.SQLite
 where
 
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
 import Data.Bifunctor (second)
@@ -1799,7 +1797,7 @@ getRcvFile db rcvFileId = runExceptT $ do
           <$> DB.query
             db
             [sql|
-              SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path, delay
+              SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path
               FROM rcv_file_chunks
               WHERE rcv_file_id = ?
             |]
@@ -1808,9 +1806,9 @@ getRcvFile db rcvFileId = runExceptT $ do
         replicas' <- getChunkReplicas rcvChunkId
         pure (chunk {replicas = replicas'} :: RcvFileChunk)
       where
-        toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath, Maybe Int) -> RcvFileChunk
-        toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath, delay) =
-          RcvFileChunk {rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay, replicas = []}
+        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
@@ -1818,7 +1816,7 @@ getRcvFile db rcvFileId = runExceptT $ do
           db
           [sql|
             SELECT
-              r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.retries,
+              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
@@ -1826,20 +1824,15 @@ getRcvFile db rcvFileId = runExceptT $ do
           |]
           (Only chunkId)
       where
-        toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
-        toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, retries, host, port, keyHash) =
+        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, retries}
+           in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}
 
-updateRcvFileChunkDelay :: DB.Connection -> Int64 -> Int -> IO ()
-updateRcvFileChunkDelay db chunkId delay = do
+updateRcvChunkReplicaDelay :: DB.Connection -> Int64 -> Int -> IO ()
+updateRcvChunkReplicaDelay db replicaId delay = do
   updatedAt <- getCurrentTime
-  DB.execute db "UPDATE rcv_file_chunks SET delay = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (delay, updatedAt, chunkId)
-
-increaseRcvChunkReplicaRetries :: DB.Connection -> Int64 -> IO ()
-increaseRcvChunkReplicaRetries db replicaId = do
-  updatedAt <- getCurrentTime
-  DB.execute db "UPDATE rcv_file_chunk_replicas SET retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, replicaId)
+  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
@@ -1875,8 +1868,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       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, c.delay,
-          r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.retries
+          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
@@ -1888,8 +1881,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
       |]
       (host, port, keyHash, RFSReceiving)
   where
-    toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath, Maybe Int) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Int)) -> RcvFileChunk
-    toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, delay) :. (rcvChunkReplicaId, replicaId, replicaKey, received, retries)) =
+    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,
@@ -1900,8 +1893,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
           digest,
           fileTmpPath,
           chunkTmpPath,
-          delay,
-          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, retries}]
+          replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
         }
 
 getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index 8853deb0e..46e9dd300 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -45,7 +45,6 @@ CREATE TABLE rcv_file_chunks (
   chunk_size INTEGER NOT NULL,
   digest BLOB NOT NULL,
   tmp_path TEXT,
-  delay INTEGER,
   created_at TEXT NOT NULL DEFAULT (datetime('now')),
   updated_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
@@ -60,7 +59,7 @@ CREATE TABLE rcv_file_chunk_replicas (
   replica_id BLOB NOT NULL,
   replica_key BLOB NOT NULL,
   received INTEGER NOT NULL DEFAULT 0,
-  -- acknowledged 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'))
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index b09f5a97b..1f17ac080 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -317,7 +317,6 @@ CREATE TABLE rcv_file_chunks(
   chunk_size INTEGER NOT NULL,
   digest BLOB NOT NULL,
   tmp_path TEXT,
-  delay INTEGER,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
@@ -330,7 +329,7 @@ CREATE TABLE rcv_file_chunk_replicas(
   replica_id BLOB NOT NULL,
   replica_key BLOB NOT NULL,
   received INTEGER NOT NULL DEFAULT 0,
-  -- acknowledged 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'))
diff --git a/src/Simplex/Messaging/Agent/TAsyncs.hs b/src/Simplex/Messaging/Agent/TAsyncs.hs
index 80fc41840..d2e2ea1f5 100644
--- a/src/Simplex/Messaging/Agent/TAsyncs.hs
+++ b/src/Simplex/Messaging/Agent/TAsyncs.hs
@@ -1,6 +1,5 @@
 module Simplex.Messaging.Agent.TAsyncs where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 1f230883b..2c5aa0728 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -12,7 +12,6 @@
 
 module Simplex.Messaging.Notifications.Server where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.Reader
diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs
index d7ce49d9b..8162b98b8 100644
--- a/src/Simplex/Messaging/Transport/Server.hs
+++ b/src/Simplex/Messaging/Transport/Server.hs
@@ -12,7 +12,6 @@ module Simplex.Messaging.Transport.Server
   )
 where
 
-import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX

From 2b1a02d7d49493bdbea09b75defa9a67ab4f2051 Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Fri, 17 Mar 2023 13:50:49 +0400
Subject: [PATCH 66/71] xftp: reconnect XFTP client on replica retry (#689)

* xftp: re-create XFTP client on replica retry

* closeXFTPSessionClient

* refactor

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Agent.hs         |  3 ++-
 src/Simplex/Messaging/Agent/Client.hs     | 30 +++++++++++++++--------
 src/Simplex/Messaging/Agent/Env/SQLite.hs |  3 +++
 3 files changed, 25 insertions(+), 11 deletions(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 6e4a84c7e..aebf5c6a4 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -95,7 +95,7 @@ runXFTPWorker c srv doWork = do
       case nextChunk of
         Nothing -> noWorkToDo
         Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
-        Just fc@RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, delay} : _} -> do
+        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 ->
@@ -110,6 +110,7 @@ runXFTPWorker c srv doWork = do
                 else done e
               where
                 retryLoop = do
+                  closeXFTPServerClient c userId replica
                   withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
                   atomically $ endAgentOperation c AORcvNetwork
                   atomically $ throwWhenInactive c
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 89559329f..8b8c1d9fa 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -25,6 +25,7 @@ module Simplex.Messaging.Agent.Client
     withConnLock,
     closeAgentClient,
     closeProtocolServerClients,
+    closeXFTPServerClient,
     runSMPServerTest,
     newRcvQueue,
     subscribeQueues,
@@ -554,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
@@ -586,14 +588,22 @@ throwWhenNoDelivery c SndQueue {server, sndId} =
 
 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) -> closeProtocolServerClient 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)
@@ -712,7 +722,7 @@ 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
@@ -724,7 +734,7 @@ 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)
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index e1263b90d..daf43b96b 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -12,6 +12,7 @@
 
 module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
+    AgentMonad',
     AgentConfig (..),
     AgentDatabase (..),
     databaseFile,
@@ -64,6 +65,8 @@ 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)
+
 data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty SMPServerWithAuth),
     ntf :: [NtfServer],

From e33d5b51841d627bd5254d416360e0236f245b13 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Fri, 17 Mar 2023 12:01:24 +0000
Subject: [PATCH 67/71] use different constraint for non-error functions (#690)

---
 src/Simplex/Messaging/Agent.hs                | 44 +++++++++----------
 src/Simplex/Messaging/Agent/Client.hs         |  4 +-
 src/Simplex/Messaging/Agent/Env/SQLite.hs     |  5 +--
 .../Messaging/Agent/NtfSubSupervisor.hs       | 14 +++---
 4 files changed, 33 insertions(+), 34 deletions(-)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index fcd68361c..75263bb14 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -291,18 +291,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'
@@ -346,30 +346,30 @@ xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int ->
 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 ()
@@ -378,10 +378,10 @@ 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, entId, cmd) <- atomically $ readTBQueue rcvQ
   runExceptT (processCommand c (entId, cmd))
@@ -802,10 +802,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
@@ -985,7 +985,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)
@@ -1325,7 +1325,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
@@ -1522,17 +1522,17 @@ sendNtfConnCommands c cmd = do
       _ ->
         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
@@ -1557,7 +1557,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
@@ -1569,7 +1569,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
@@ -1588,7 +1588,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 $
@@ -1596,7 +1596,7 @@ 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)
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 8b8c1d9fa..68a99c52c 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -544,7 +544,7 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconne
 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
@@ -728,7 +728,7 @@ mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> ge
 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
diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs
index daf43b96b..5deb6ed67 100644
--- a/src/Simplex/Messaging/Agent/Env/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs
@@ -62,11 +62,10 @@ 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],
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 4061335b7..52f09a6c9 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
@@ -48,7 +48,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
@@ -154,7 +154,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 ()
@@ -288,7 +288,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
@@ -304,7 +304,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
@@ -324,10 +324,10 @@ workerInternalError c connId internalErrStr = do
   notifyInternalError c connId internalErrStr
 
 -- TODO change error
-notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m ()
+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
@@ -358,7 +358,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

From 02eb1e98220a737c93ab946f5432ebb3c00247a2 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Mar 2023 07:57:25 +0000
Subject: [PATCH 68/71] add stateTVar imports for compatibility with older
 hackage index in nix builds

---
 src/Simplex/Messaging/Agent.hs                  | 1 +
 src/Simplex/Messaging/Agent/NtfSubSupervisor.hs | 1 +
 src/Simplex/Messaging/Agent/Store/SQLite.hs     | 1 +
 src/Simplex/Messaging/Agent/TAsyncs.hs          | 1 +
 src/Simplex/Messaging/Notifications/Server.hs   | 1 +
 src/Simplex/Messaging/Transport/Server.hs       | 1 +
 6 files changed, 6 insertions(+)

diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 75263bb14..1adc17f92 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -92,6 +92,7 @@ module Simplex.Messaging.Agent
   )
 where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo, showText)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
index 52f09a6c9..ebd4a9937 100644
--- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
@@ -18,6 +18,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
 where
 
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
 import Control.Monad.Except
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index b8e02fc49..b3ac192ef 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -147,6 +147,7 @@ module Simplex.Messaging.Agent.Store.SQLite
 where
 
 import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
 import Data.Bifunctor (second)
diff --git a/src/Simplex/Messaging/Agent/TAsyncs.hs b/src/Simplex/Messaging/Agent/TAsyncs.hs
index d2e2ea1f5..80fc41840 100644
--- a/src/Simplex/Messaging/Agent/TAsyncs.hs
+++ b/src/Simplex/Messaging/Agent/TAsyncs.hs
@@ -1,5 +1,6 @@
 module Simplex.Messaging.Agent.TAsyncs where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs
index 2c5aa0728..1f230883b 100644
--- a/src/Simplex/Messaging/Notifications/Server.hs
+++ b/src/Simplex/Messaging/Notifications/Server.hs
@@ -12,6 +12,7 @@
 
 module Simplex.Messaging.Notifications.Server where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.Reader
diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs
index 8162b98b8..d7ce49d9b 100644
--- a/src/Simplex/Messaging/Transport/Server.hs
+++ b/src/Simplex/Messaging/Transport/Server.hs
@@ -12,6 +12,7 @@ module Simplex.Messaging.Transport.Server
   )
 where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX

From 2e02ba86fdc548b910aa830c7d36a4274a304d33 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Mar 2023 13:38:20 +0000
Subject: [PATCH 69/71] add stateTVar import

---
 src/Simplex/FileTransfer/Client/Main.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs
index ed626b4dd..5ed5d5eba 100644
--- a/src/Simplex/FileTransfer/Client/Main.hs
+++ b/src/Simplex/FileTransfer/Client/Main.hs
@@ -18,6 +18,7 @@ module Simplex.FileTransfer.Client.Main
   )
 where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except

From 40da7e76ddd5694da386720f61a69d5a15812a81 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 18 Mar 2023 13:48:17 +0000
Subject: [PATCH 70/71] import stateTVar

---
 src/Simplex/FileTransfer/Agent.hs     | 1 +
 src/Simplex/Messaging/Agent/Client.hs | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index aebf5c6a4..667a0ae3f 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -19,6 +19,7 @@ module Simplex.FileTransfer.Agent
   )
 where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError)
 import Control.Monad
 import Control.Monad.Except
diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs
index 68a99c52c..245c17d09 100644
--- a/src/Simplex/Messaging/Agent/Client.hs
+++ b/src/Simplex/Messaging/Agent/Client.hs
@@ -88,7 +88,7 @@ where
 import Control.Applicative ((<|>))
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (retry, throwSTM)
+import Control.Concurrent.STM (retry, stateTVar, throwSTM)
 import Control.Exception (AsyncException (..))
 import Control.Logger.Simple
 import Control.Monad.Except

From 2bec353eae09a0561a94e8c8ef17054dee70c2ad Mon Sep 17 00:00:00 2001
From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Date: Mon, 20 Mar 2023 20:08:38 +0400
Subject: [PATCH 71/71] xftp: add command to delete rcv file; agent manages
 save path (#692)

---
 simplexmq.cabal                               |  2 +-
 src/Simplex/FileTransfer/Agent.hs             | 44 ++++++----
 src/Simplex/FileTransfer/Types.hs             |  4 +-
 src/Simplex/Messaging/Agent.hs                | 25 ++++--
 src/Simplex/Messaging/Agent/Protocol.hs       |  8 +-
 src/Simplex/Messaging/Agent/Store/SQLite.hs   | 80 +++++++++++++++----
 .../SQLite/Migrations/M20230223_files.hs      |  2 +
 ...07_snd_files.hs => M20230401_snd_files.hs} |  6 +-
 .../Store/SQLite/Migrations/agent_schema.sql  |  2 +
 tests/XFTPAgent.hs                            | 51 ++++++------
 10 files changed, 151 insertions(+), 73 deletions(-)
 rename src/Simplex/Messaging/Agent/Store/SQLite/Migrations/{M20230307_snd_files.hs => M20230401_snd_files.hs} (96%)

diff --git a/simplexmq.cabal b/simplexmq.cabal
index cd0da9b3c..9140410be 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -78,7 +78,7 @@ library
       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.M20230307_snd_files
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files
       Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs
index 667a0ae3f..12ac35548 100644
--- a/src/Simplex/FileTransfer/Agent.hs
+++ b/src/Simplex/FileTransfer/Agent.hs
@@ -13,6 +13,7 @@ module Simplex.FileTransfer.Agent
   ( -- Receiving files
     receiveFile,
     addXFTPWorker,
+    deleteRcvFile,
     -- Sending files
     sendFileExperimental,
     _sendFile,
@@ -32,6 +33,8 @@ 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
@@ -54,13 +57,19 @@ import UnliftIO.Concurrent
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 
-receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> FilePath -> m RcvFileId
-receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath savePath = do
+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
-  encPath <- uniqueCombine workPath "xftp.encrypted"
-  createDirectory encPath
-  fId <- withStore c $ \db -> createRcvFile db g userId fd encPath savePath
+  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
@@ -69,6 +78,11 @@ receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWork
       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
@@ -129,9 +143,6 @@ runXFTPWorker c srv doWork = do
         when fileReceived $
           liftIO $ updateRcvFileStatus db rcvFileId RFSReceived
         pure fileReceived
-      -- check if chunk is downloaded and not acknowledged via flag acknowledged?
-      -- or just catch and ignore error on acknowledgement? (and remove flag)
-      -- agentXFTPAckChunk c replicaKey (unChunkReplicaId replicaId) `catchError` \_ -> pure ()
       when fileReceived $ addXFTPWorker c Nothing
       where
         allChunksReceived :: RcvFile -> Bool
@@ -165,19 +176,15 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, chunks} = do
       -- TODO test; recreate file if it's in status RFSDecrypting
       -- when (status == RFSDecrypting) $
-      --   whenM (doesFileExist savePath) (removeFile savePath >> emptyFile)
+      --   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
+      notify $ RFDONE savePath
       where
-        -- emptyFile :: m ()
-        -- emptyFile = do
-        --   h <- openFile savePath AppendMode
-        --   liftIO $ B.hPut h "" >> hFlush h
         notify :: forall e. AEntityI e => ACommand 'Agent e -> m ()
         notify cmd = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC (sAEntity @e) cmd)
         getChunkPaths :: [RcvFileChunk] -> m [FilePath]
@@ -188,6 +195,15 @@ runXFTPLocalWorker c@AgentClient {subQ} doWork = do
         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
diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs
index e71460fc2..578d98ac6 100644
--- a/src/Simplex/FileTransfer/Types.hs
+++ b/src/Simplex/FileTransfer/Types.hs
@@ -46,9 +46,11 @@ data RcvFile = RcvFile
     nonce :: C.CbNonce,
     chunkSize :: FileSize Word32,
     chunks :: [RcvFileChunk],
+    prefixPath :: FilePath,
     tmpPath :: Maybe FilePath,
     savePath :: FilePath,
-    status :: RcvFileStatus
+    status :: RcvFileStatus,
+    deleted :: Bool
   }
   deriving (Eq, Show)
 
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 1adc17f92..8d037c185 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -81,6 +81,7 @@ module Simplex.Messaging.Agent
     getNtfTokenData,
     toggleConnectionNtfs,
     xftpReceiveFile,
+    xftpDeleteRcvFile,
     xftpSendFile,
     activateAgent,
     suspendAgent,
@@ -115,7 +116,7 @@ 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, receiveFile, sendFileExperimental)
+import Simplex.FileTransfer.Agent (addXFTPWorker, deleteRcvFile, receiveFile, sendFileExperimental)
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Util (removePath)
@@ -339,8 +340,12 @@ 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 -> FilePath -> m RcvFileId
-xftpReceiveFile c = withAgentEnv c .:: receiveFile c
+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
@@ -1604,7 +1609,7 @@ cleanupManager c = do
   forever $ do
     void . runExceptT $ do
       deleteConns
-      deleteTmpPaths
+      deleteFiles
       threadDelay int
   where
     deleteConns =
@@ -1612,9 +1617,15 @@ cleanupManager c = do
         void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
         withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted
     notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
-    deleteTmpPaths = do
-      tmpPaths <- withStore' c getTmpFilePaths
-      forM_ tmpPaths $ \(fId, p) -> do
+    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)
 
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 77b1c4ccf..7d7d1180b 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -337,7 +337,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   SUSPENDED :: ACommand Agent AENone
   -- XFTP commands and responses
   RFPROG :: Int -> Int -> ACommand Agent AERcvFile
-  RFDONE :: 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
@@ -443,7 +443,7 @@ aCommandTag = \case
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
   RFPROG {} -> RFPROG_
-  RFDONE -> RFDONE_
+  RFDONE {} -> RFDONE_
   RFERR {} -> RFERR_
   SFPROG {} -> SFPROG_
   SFDONE {} -> SFDONE_
@@ -1447,7 +1447,7 @@ commandP binaryP =
           ERR_ -> s (ERR <$> strP)
           SUSPENDED_ -> pure SUSPENDED
           RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal)
-          RFDONE_ -> pure RFDONE
+          RFDONE_ -> s (RFDONE <$> strP)
           RFERR_ -> s (RFERR <$> strP)
           SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal)
           SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP)
@@ -1511,7 +1511,7 @@ serializeCommand = \case
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
   RFPROG rcvd total -> s (RFPROG_, rcvd, total)
-  RFDONE -> s RFDONE_
+  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)]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs
index b3ac192ef..2ad2015dd 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs
@@ -126,16 +126,20 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- File transfer
     createRcvFile,
     getRcvFile,
+    getRcvFileByEntityId,
     updateRcvChunkReplicaDelay,
     updateRcvFileChunkReceived,
     updateRcvFileStatus,
     updateRcvFileError,
     updateRcvFileComplete,
     updateRcvFileNoTmpPath,
+    updateRcvFileDeleted,
+    deleteRcvFile',
     getNextRcvChunkToDownload,
     getNextRcvFileToDecrypt,
     getPendingRcvFilesServers,
-    getTmpFilePaths,
+    getCleanupRcvFilesTmpPaths,
+    getCleanupRcvFilesDeleted,
 
     -- * utilities
     withConnection,
@@ -1736,8 +1740,8 @@ 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 -> IO (Either StoreError RcvFileId)
-createRcvFile db gVar userId fd@FileDescription {chunks} tmpPath savePath = runExceptT $ do
+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
@@ -1751,8 +1755,8 @@ createRcvFile db gVar userId fd@FileDescription {chunks} tmpPath savePath = runE
         createWithRandomId gVar $ \rcvFileEntityId ->
           DB.execute
             db
-            "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_path, status) VALUES (?,?,?,?,?,?,?,?,?,?)"
-            (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, RFSReceiving)
+            "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
@@ -1770,6 +1774,16 @@ createRcvFile db gVar userId fd@FileDescription {chunks} tmpPath savePath = runE
         "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
@@ -1782,15 +1796,15 @@ getRcvFile db rcvFileId = runExceptT $ do
         DB.query
           db
           [sql|
-            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, tmp_path, save_path, status
+            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, Maybe FilePath, FilePath, RcvFileStatus) -> RcvFile
-        toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, status) =
-          RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, tmpPath, savePath, status, chunks = []}
+        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 <-
@@ -1862,6 +1876,15 @@ 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 $
@@ -1876,7 +1899,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do
         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 r.received = 0 AND r.replica_number = 1
+          AND f.status = ? AND f.deleted = 0
         ORDER BY r.created_at ASC
         LIMIT 1
       |]
@@ -1901,7 +1925,15 @@ getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile)
 getNextRcvFileToDecrypt db = do
   fileId_ :: Maybe DBRcvFileId <-
     maybeFirstRow fromOnly $
-      DB.query db "SELECT rcv_file_id FROM rcv_files WHERE status IN (?,?) ORDER BY created_at ASC LIMIT 1" (RFSReceived, RFSDecrypting)
+      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
@@ -1918,13 +1950,31 @@ getPendingRcvFilesServers db = do
         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 = ?
+        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
 
-getTmpFilePaths :: DB.Connection -> IO [(DBRcvFileId, FilePath)]
-getTmpFilePaths db =
-  DB.query db "SELECT rcv_file_id, tmp_path FROM rcv_files WHERE status IN (?,?) AND tmp_path IS NOT NULL" (RFSComplete, RFSError)
+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
+    |]
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
index 46e9dd300..1bae366a7 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs
@@ -27,9 +27,11 @@ CREATE TABLE rcv_files (
   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')),
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs
similarity index 96%
rename from src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs
rename to src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs
index 3cfc96117..df5754fb2 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230307_snd_files.hs
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs
@@ -1,13 +1,13 @@
 {-# LANGUAGE QuasiQuotes #-}
 
-module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230307_snd_files where
+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
-m20230307_snd_files :: Query
-m20230307_snd_files =
+m20230401_snd_files :: Query
+m20230401_snd_files =
   [sql|
 CREATE TABLE snd_files (
   snd_file_id INTEGER PRIMARY KEY AUTOINCREMENT,
diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
index 1f17ac080..29de284f9 100644
--- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
@@ -301,9 +301,11 @@ CREATE TABLE rcv_files(
   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')),
diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs
index db04e1d20..ba87160da 100644
--- a/tests/XFTPAgent.hs
+++ b/tests/XFTPAgent.hs
@@ -13,12 +13,11 @@ 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, xftpReceiveFile, xftpSendFile)
+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)
+import System.Directory (doesDirectoryExist, getFileSize, listDirectory)
 import System.FilePath ((</>))
-import System.Process (readCreateProcess, shell)
 import System.Timeout (timeout)
 import Test.Hspec
 import XFTPCLI
@@ -29,7 +28,7 @@ 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 -- TODO uses default servers (remote)
+  it "should send file using experimental api" testXFTPAgentSendExperimental
 
 testXFTPAgentReceive :: IO ()
 testXFTPAgentReceive = withXFTPServer $ do
@@ -49,18 +48,16 @@ testXFTPAgentReceive = withXFTPServer $ do
                ]
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
-  let savePath = recipientFiles </> "testfile"
-  run $ "touch " <> savePath
   runRight_ $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath
-    ("", fId', RFDONE) <- rfGet rcp
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles)
+    ("", fId', RFDONE path) <- rfGet rcp
     liftIO $ do
       fId' `shouldBe` fId
-      B.readFile savePath `shouldReturn` file
+      B.readFile path `shouldReturn` file
 
-run :: String -> IO ()
-run cmd = void $ readCreateProcess (shell cmd) ""
+    -- delete file
+    xftpDeleteRcvFile rcp 1 fId
 
 getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
 getFileDescription path =
@@ -88,29 +85,29 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
                  ]
 
   -- receive file using agent - should not succeed due to server being down
-  let savePath = recipientFiles </> "testfile"
-  run $ "touch " <> savePath
   rcp <- getSMPAgentClient agentCfg initAgentServers
   fId <- runRight $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles)
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
   disconnectAgentClient rcp
 
-  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` True
+  [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) <- rfGet rcp'
+    ("", fId', RFDONE path) <- rfGet rcp'
     liftIO $ do
       fId' `shouldBe` fId
       file <- B.readFile filePath
-      B.readFile savePath `shouldReturn` file
+      B.readFile path `shouldReturn` file
 
   -- tmp path should be removed after receiving file
-  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
+  doesDirectoryExist tmpPath `shouldReturn` False
 
 testXFTPAgentReceiveCleanup :: IO ()
 testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
@@ -132,16 +129,16 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
 
   -- receive file using agent - should not succeed due to server being down
   rcp <- getSMPAgentClient agentCfg initAgentServers
-  let savePath = recipientFiles </> "testfile"
-  run $ "touch " <> savePath
   fId <- runRight $ do
     fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv
-    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) savePath
+    fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles)
     liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
     pure fId
   disconnectAgentClient rcp
 
-  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` True
+  [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
@@ -150,7 +147,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
     fId' `shouldBe` fId
 
   -- tmp path should be removed after permanent error
-  doesDirectoryExist (recipientFiles </> "xftp.encrypted") `shouldReturn` False
+  doesDirectoryExist tmpPath `shouldReturn` False
 
 testXFTPAgentSendExperimental :: IO ()
 testXFTPAgentSendExperimental = withXFTPServer $ do
@@ -175,11 +172,9 @@ testXFTPAgentSendExperimental = withXFTPServer $ do
 
   -- receive file using agent
   rcp <- getSMPAgentClient agentCfg initAgentServers
-  let savePath = recipientFiles </> "testfile"
-  run $ "touch " <> savePath
   runRight_ $ do
-    rfId <- xftpReceiveFile rcp 1 rfd (Just recipientFiles) savePath
-    ("", rfId', RFDONE) <- rfGet rcp
+    rfId <- xftpReceiveFile rcp 1 rfd (Just recipientFiles)
+    ("", rfId', RFDONE path) <- rfGet rcp
     liftIO $ do
       rfId' `shouldBe` rfId
-      B.readFile savePath `shouldReturn` file
+      B.readFile path `shouldReturn` file