v5.0.0-beta.3

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

* enable all tests

.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 }}

CHANGELOG.md

@@ -1,3 +1,10 @@
+# 4.4.1
+
+SMP agent:
+
+- fix handling of server addresses.
+- prevent message delivery getting stuck on IO error in SMP client.
+
 # 4.4.0
 
 SMP agent:

apps/xftp-server/Main.hs

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

apps/xftp/Main.hs

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

cabal.project

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

package.yaml

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

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://[email protected]
     chunks: [1:abc=:def=:ghi=, 3:abc=:def=:ghi=]
   - server: xftp://[email protected]
-    chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=]
+    chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=:2mb]
   - server: xftp://[email protected]
     chunks: [1:abc=:def=, 4:abc=:def=]
   - server: xftp://[email protected]

simplexmq.cabal

@@ -1,11 +1,11 @@
 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
 
 name:           simplexmq
-version:        4.4.0
+version:        5.0.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -34,6 +34,19 @@ flag swift
 
 library
   exposed-modules:
+      Simplex.FileTransfer
+      Simplex.FileTransfer.Client
+      Simplex.FileTransfer.Client.Agent
+      Simplex.FileTransfer.Client.Main
+      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
@@ -58,11 +71,13 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
       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.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
+      Simplex.Messaging.Crypto.Lazy
       Simplex.Messaging.Crypto.Ratchet
       Simplex.Messaging.Encoding
       Simplex.Messaging.Encoding.String
@@ -92,6 +107,7 @@ library
       Simplex.Messaging.Server.StoreLog
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
+      Simplex.Messaging.Transport.Buffer
       Simplex.Messaging.Transport.Client
       Simplex.Messaging.Transport.HTTP2
       Simplex.Messaging.Transport.HTTP2.Client
@@ -129,7 +145,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.*
@@ -144,6 +160,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.*
@@ -156,6 +173,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
@@ -190,7 +208,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.*
@@ -218,6 +236,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
@@ -252,7 +271,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.*
@@ -280,6 +299,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
@@ -314,7 +334,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.*
@@ -342,11 +362,139 @@ 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
 
-test-suite smp-server-test
+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:
+      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.*
+    , yaml ==0.11.*
+  default-language: Haskell2010
+  if flag(swift)
+    cpp-options: -DswiftJSON
+
+test-suite simplexmq-test
   type: exitcode-stdio-1.0
   main-is: Test.hs
   other-modules:
@@ -363,11 +511,15 @@ test-suite smp-server-test
       CoreTests.ProtocolErrorTests
       CoreTests.RetryIntervalTests
       CoreTests.VersionRangeTests
+      FileDescriptionTests
       NtfClient
       NtfServerTests
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPCLI
+      XFTPClient
+      XFTPServerTests
       Paths_simplexmq
   hs-source-dirs:
       tests
@@ -398,7 +550,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.*
@@ -429,6 +581,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

src/Simplex/FileTransfer.hs

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

src/Simplex/FileTransfer/Client.hs

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

src/Simplex/FileTransfer/Client/Agent.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Client.Agent where
+
+import Control.Logger.Simple (logInfo)
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Char8 as B
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Simplex.FileTransfer.Client
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
+import Simplex.Messaging.Client.Agent ()
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (catchAll_, tryError)
+import UnliftIO
+
+type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
+
+data XFTPClientAgent = XFTPClientAgent
+  { xftpClients :: TMap XFTPServer XFTPClientVar,
+    config :: XFTPClientAgentConfig
+  }
+
+data XFTPClientAgentConfig = XFTPClientAgentConfig
+  { xftpConfig :: XFTPClientConfig,
+    reconnectInterval :: RetryInterval
+  }
+
+defaultXFTPClientAgentConfig :: XFTPClientAgentConfig
+defaultXFTPClientAgentConfig =
+  XFTPClientAgentConfig
+    { xftpConfig = defaultXFTPClientConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = 5_000000,
+            increaseAfter = 10_000000,
+            maxInterval = 60_000000
+          }
+    }
+
+data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
+  deriving (Show, Exception)
+
+newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent
+newXFTPAgent config = do
+  xftpClients <- TM.empty
+  pure XFTPClientAgent {xftpClients, config}
+
+type ME a = ExceptT XFTPClientAgentError IO a
+
+getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
+getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
+  atomically getClientVar >>= either newXFTPClient waitForXFTPClient
+  where
+    connectClient :: ME XFTPClient
+    connectClient =
+      ExceptT $
+        first (XFTPClientAgentError srv)
+          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
+
+    clientDisconnected :: 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)
+
+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 ()

src/Simplex/FileTransfer/Client/Main.hs

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

src/Simplex/FileTransfer/Description.hs

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

src/Simplex/FileTransfer/Protocol.hs

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

src/Simplex/FileTransfer/Server.hs

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

src/Simplex/FileTransfer/Server/Env.hs

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

src/Simplex/FileTransfer/Server/Main.hs

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

src/Simplex/FileTransfer/Server/Stats.hs

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

src/Simplex/FileTransfer/Server/Store.hs

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

src/Simplex/FileTransfer/Server/StoreLog.hs

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

src/Simplex/FileTransfer/Transport.hs

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

src/Simplex/Messaging/Agent.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      : Simplex.Messaging.Agent
@@ -472,7 +473,7 @@ deleteConnectionsAsync_ :: forall m. AgentMonad m => m () -> AgentClient -> [Con
 deleteConnectionsAsync_ onSuccess c connIds = case connIds of
   [] -> onSuccess
   _ -> do
-    (_, rqs, connIds') <- prepareDeleteConnections_ getConn c connIds
+    (_, rqs, connIds') <- prepareDeleteConnections_ getConns c connIds
     withStore' c $ forM_ connIds' . setConnDeleted
     void . forkIO $
       withLock (deleteLock c) "deleteConnectionsAsync" $
@@ -628,7 +629,7 @@ type QCmdResult = (QueueStatus, Either AgentErrorType ())
 subscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
 subscribeConnections' _ [] = pure M.empty
 subscribeConnections' c connIds = do
-  conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConn)
+  conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConns` connIds)
   let (errs, cs) = M.mapEither id conns
       errs' = M.map (Left . storeError) errs
       (subRs, rcvQs) = M.mapEither rcvQueueOrResult cs
@@ -756,7 +757,7 @@ sendMessage' c connId msgFlags msg = withConnLock c connId "sendMessage" $ do
 enqueueCommand :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> m ()
 enqueueCommand c corrId connId server aCommand = do
   resumeSrvCmds c server
-  commandId <- withStore' c $ \db -> createCommand db corrId connId server aCommand
+  commandId <- withStore c $ \db -> createCommand db corrId connId server aCommand
   queuePendingCommands c server [commandId]
 
 resumeSrvCmds :: forall m. AgentMonad m => AgentClient -> Maybe SMPServer -> m ()
@@ -1193,20 +1194,20 @@ disableConn c connId = do
 
 -- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
 deleteConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
-deleteConnections' = deleteConnections_ getConn False
+deleteConnections' = deleteConnections_ getConns False
 
 deleteDeletedConns :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
-deleteDeletedConns = deleteConnections_ getDeletedConn True
+deleteDeletedConns = deleteConnections_ getDeletedConns True
 
 prepareDeleteConnections_ ::
   forall m.
   AgentMonad m =>
-  (DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) ->
+  (DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
   AgentClient ->
   [ConnId] ->
   m (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
-prepareDeleteConnections_ getConnection c connIds = do
-  conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConnection)
+prepareDeleteConnections_ getConnections c connIds = do
+  conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConnections` connIds)
   let (errs, cs) = M.mapEither id conns
       errs' = M.map (Left . storeError) errs
       (delRs, rcvQs) = M.mapEither rcvQueues cs
@@ -1259,14 +1260,14 @@ deleteConnQueues c ntf rqs = do
 deleteConnections_ ::
   forall m.
   AgentMonad m =>
-  (DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) ->
+  (DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
   Bool ->
   AgentClient ->
   [ConnId] ->
   m (Map ConnId (Either AgentErrorType ()))
 deleteConnections_ _ _ _ [] = pure M.empty
-deleteConnections_ getConnection ntf c connIds = do
-  (rs, rqs, _) <- prepareDeleteConnections_ getConnection c connIds
+deleteConnections_ getConnections ntf c connIds = do
+  (rs, rqs, _) <- prepareDeleteConnections_ getConnections c connIds
   rcvRs <- deleteConnQueues c ntf rqs
   let rs' = M.union rs rcvRs
   notifyResultError rs'
@@ -1576,7 +1577,7 @@ cleanupManager c = do
   forever $ do
     void . runExceptT $
       withLock (deleteLock c) "cleanupManager" $ do
-        void $ withStore' c getDeletedConns >>= deleteDeletedConns c
+        void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
         withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted
     threadDelay int
   where

src/Simplex/Messaging/Agent/Client.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -162,7 +163,7 @@ import UnliftIO (mapConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-type ClientVar msg = TMVar (Either AgentErrorType (ProtocolClient msg))
+type ClientVar err msg = TMVar (Either AgentErrorType (ProtocolClient err msg))
 
 type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
 
@@ -319,15 +320,15 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
 agentClientStore :: AgentClient -> SQLiteStore
 agentClientStore AgentClient {agentEnv = Env {store}} = store
 
-class ProtocolServerClient msg where
-  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient msg)
-  clientProtocolError :: ErrorType -> AgentErrorType
+class ProtocolServerClient err msg | msg -> err where
+  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient err msg)
+  clientProtocolError :: err -> AgentErrorType
 
-instance ProtocolServerClient BrokerMsg where
+instance ProtocolServerClient ErrorType BrokerMsg where
   getProtocolServerClient = getSMPServerClient
   clientProtocolError = SMP
 
-instance ProtocolServerClient NtfResponse where
+instance ProtocolServerClient ErrorType NtfResponse where
   getProtocolServerClient = getNtfServerClient
   clientProtocolError = NTF
 
@@ -428,7 +429,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 msg -> m (ProtocolClient msg)
+waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar err msg -> m (ProtocolClient err msg)
 waitForProtocolClient c (_, srv, _) clientVar = do
   NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
   client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
@@ -438,18 +439,18 @@ waitForProtocolClient c (_, srv, _) clientVar = do
     Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
 
 newProtocolClient ::
-  forall msg m.
+  forall err msg m.
   (AgentMonad m, ProtocolTypeI (ProtoType msg)) =>
   AgentClient ->
   TransportSession msg ->
-  TMap (TransportSession msg) (ClientVar msg) ->
-  m (ProtocolClient msg) ->
+  TMap (TransportSession msg) (ClientVar err msg) ->
+  m (ProtocolClient err msg) ->
   (AgentClient -> TransportSession msg -> m ()) ->
-  ClientVar msg ->
-  m (ProtocolClient msg)
+  ClientVar err msg ->
+  m (ProtocolClient err msg)
 newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
   where
-    tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a
+    tryConnectClient :: (ProtocolClient err msg -> m a) -> m () -> m a
     tryConnectClient successAction retryAction =
       tryError connectClient >>= \r -> case r of
         Right client -> do
@@ -474,7 +475,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 msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent
+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
 
 getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
@@ -518,7 +519,7 @@ throwWhenNoDelivery c SndQueue {server, sndId} =
   where
     k = (server, sndId)
 
-closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
+closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar err msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
   atomically (swapTVar cs M.empty) >>= mapM_ (forkIO . closeClient)
   where
@@ -541,32 +542,32 @@ 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 msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err 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 msg -> AgentErrorType -> m a
+    logServerError :: ProtocolClient err msg -> AgentErrorType -> m a
     logServerError cl e = do
       logServer "<--" c srv "" $ strEncode e
       stat cl $ strEncode e
       throwError e
 
-withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err 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 msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client
+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 c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
 
-withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @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 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 ProtocolClientError IO a) -> m a
+withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
 withSMPClient c q cmdStr action = do
   tSess <- mkSMPTransportSession c q
   withLogClient c tSess (queueId q) cmdStr action
@@ -576,23 +577,23 @@ withSMPClient_ c q cmdStr action = do
   tSess <- mkSMPTransportSession c q
   withLogClient_ c tSess (queueId q) cmdStr action
 
-withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT ProtocolClientError IO a) -> m a
+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)
 
-liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> HostName -> ExceptT ProtocolClientError IO a -> m a
+liftClient :: (AgentMonad m, Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> m a
 liftClient protocolError_ = liftError . protocolClientError protocolError_
 
-protocolClientError :: (ErrorType -> AgentErrorType) -> HostName -> ProtocolClientError -> AgentErrorType
+protocolClientError :: (Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ProtocolClientError err -> AgentErrorType
 protocolClientError protocolError_ host = \case
   PCEProtocolError e -> protocolError_ e
-  PCEResponseError e -> BROKER host $ RESPONSE e
+  PCEResponseError e -> BROKER host $ RESPONSE $ B.unpack $ smpEncode e
   PCEUnexpectedResponse _ -> BROKER host UNEXPECTED
   PCEResponseTimeout -> BROKER host TIMEOUT
   PCENetworkError -> BROKER host NETWORK
   PCEIncompatibleHost -> BROKER host HOST
   PCETransportError e -> BROKER host $ TRANSPORT e
-  e@PCESignatureError {} -> INTERNAL $ show e
-  e@PCEIOError {} -> INTERNAL $ show e
+  e@PCECryptoError {} -> INTERNAL $ show e
+  PCEIOError {} -> BROKER host NETWORK
 
 data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
   deriving (Eq, Show, Generic)
@@ -632,7 +633,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
       Left e -> pure (Just $ testErr TSConnect e)
   where
     addr = B.unpack $ strEncode srv
-    testErr :: SMPTestStep -> ProtocolClientError -> SMPTestFailure
+    testErr :: SMPTestStep -> SMPClientError -> SMPTestFailure
     testErr step = SMPTestFailure step . protocolClientError SMP addr
 
 mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
@@ -682,7 +683,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do
           }
   pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey)
 
-processSubResult :: AgentClient -> RcvQueue -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
+processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> IO (Either SMPClientError ())
 processSubResult c rq r = do
   case r of
     Left e ->
@@ -691,12 +692,6 @@ processSubResult c rq r = do
     _ -> addSubscription c rq
   pure r
 
-temporaryClientError :: ProtocolClientError -> Bool
-temporaryClientError = \case
-  PCENetworkError -> True
-  PCEResponseTimeout -> True
-  _ -> False
-
 temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
   BROKER _ NETWORK -> True
@@ -731,7 +726,7 @@ subscribeQueues c qs = do
 type BatchResponses e = (NonEmpty (RcvQueue, Either e ()))
 
 -- statBatchSize is not used to batch the commands, only for traffic statistics
-sendTSessionBatches :: forall m. AgentMonad m => ByteString -> Int -> (SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses ProtocolClientError)) -> AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+sendTSessionBatches :: forall m. AgentMonad m => ByteString -> Int -> (SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError)) -> AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
 sendTSessionBatches statCmd statBatchSize action c qs =
   concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
   where
@@ -758,7 +753,7 @@ sendTSessionBatches statCmd statBatchSize action c qs =
               let n = (length qs - 1) `div` statBatchSize + 1
                in incClientStatN c userId smp n (statCmd <> "S") "OK"
 
-sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses ProtocolClientError)
+sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError)
 sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
   where
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
@@ -1046,7 +1041,7 @@ incStat AgentClient {agentStats} n k = do
     Just v -> modifyTVar' v (+ n)
     _ -> newTVar n >>= \v -> TM.insert k v agentStats
 
-incClientStat :: AgentClient -> UserId -> ProtocolClient msg -> ByteString -> ByteString -> IO ()
+incClientStat :: AgentClient -> UserId -> ProtocolClient err msg -> ByteString -> ByteString -> IO ()
 incClientStat c userId pc = incClientStatN c userId pc 1
 
 incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO ()
@@ -1056,7 +1051,7 @@ incServerStat c userId ProtocolServer {host} cmd res = do
   where
     statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res}
 
-incClientStatN :: AgentClient -> UserId -> ProtocolClient msg -> Int -> ByteString -> ByteString -> IO ()
+incClientStatN :: AgentClient -> UserId -> ProtocolClient err msg -> Int -> ByteString -> ByteString -> IO ()
 incClientStatN c userId pc n cmd res = do
   atomically $ incStat c n statsKey
   where

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

@@ -123,13 +123,13 @@ defaultMessageRetryInterval =
             maxInterval = 60_000000
           },
       riSlow =
-        -- TODO: these timeouts can be increased in v4.6 once most clients are updated
+        -- TODO: these timeouts can be increased in v5.0 once most clients are updated
         -- to resume sending on QCONT messages.
         -- After that local message expiration period should be also increased.
         RetryInterval
-          { initialInterval = 30_000000,
-            increaseAfter = 30_000000,
-            maxInterval = 600_000000
+          { initialInterval = 60_000000,
+            increaseAfter = 60_000000,
+            maxInterval = 1200_000000 -- 20min
           }
     }
 

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -82,11 +82,11 @@ processNtfSub c (connId, cmd) = do
             case clientNtfCreds of
               Just ClientNtfCreds {notifierId} -> do
                 let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
-                withStore' c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
+                withStore c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
                 addNtfNTFWorker ntfServer
               Nothing -> do
                 let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
-                withStore' c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
+                withStore c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
                 addNtfSMPWorker smpServer
         (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
           case (clientNtfCreds, ntfQueueId) of

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
@@ -1121,7 +1123,7 @@ instance ToJSON ConnectionErrorType where
 -- | SMP server errors.
 data BrokerErrorType
   = -- | invalid server response (failed to parse)
-    RESPONSE {smpErr :: ErrorType}
+    RESPONSE {smpErr :: String}
   | -- | unexpected response
     UNEXPECTED
   | -- | network error
@@ -1164,27 +1166,27 @@ instance StrEncoding AgentErrorType where
       <|> "CONN " *> (CONN <$> parseRead1)
       <|> "SMP " *> (SMP <$> strP)
       <|> "NTF " *> (NTF <$> strP)
-      <|> "BROKER " *> (BROKER <$> srvP <* " RESPONSE " <*> (RESPONSE <$> strP))
-      <|> "BROKER " *> (BROKER <$> srvP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
-      <|> "BROKER " *> (BROKER <$> srvP <* A.space <*> parseRead1)
+      <|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
+      <|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
+      <|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
       <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
       <|> "AGENT " *> (AGENT <$> parseRead1)
       <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
     where
-      srvP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
+      textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
   strEncode = \case
     CMD e -> "CMD " <> bshow e
     CONN e -> "CONN " <> bshow e
     SMP e -> "SMP " <> strEncode e
     NTF e -> "NTF " <> strEncode e
-    BROKER srv (RESPONSE e) -> "BROKER " <> addr srv <> " RESPONSE " <> strEncode e
-    BROKER srv (TRANSPORT e) -> "BROKER " <> addr srv <> " TRANSPORT " <> serializeTransportError e
-    BROKER srv e -> "BROKER " <> addr srv <> " " <> bshow 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
     AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
     AGENT e -> "AGENT " <> bshow e
     INTERNAL e -> "INTERNAL " <> bshow e
     where
-      addr = encodeUtf8 . T.pack
+      text = encodeUtf8 . T.pack
 
 instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
 
@@ -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

src/Simplex/Messaging/Agent/Store.hs

@@ -510,6 +510,8 @@ data StoreError
     SEUserNotFound
   | -- | Connection not found (or both queues absent).
     SEConnNotFound
+  | -- | Server not found.
+    SEServerNotFound
   | -- | Connection already used.
     SEConnDuplicate
   | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.

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

@@ -43,9 +43,11 @@ module Simplex.Messaging.Agent.Store.SQLite
     createSndConn,
     getConn,
     getDeletedConn,
+    getConns,
+    getDeletedConns,
     getConnData,
     setConnDeleted,
-    getDeletedConns,
+    getDeletedConnIds,
     getRcvConn,
     deleteConn,
     upgradeRcvConnToDuplex,
@@ -398,16 +400,16 @@ updateNewConnSnd db connId sq =
 createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId)
 createRcvConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode =
   createConn_ gVar cData $ \connId -> do
-    upsertServer_ db server
+    serverKeyHash_ <- createServer_ db server
     DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
-    void $ insertRcvQueue_ db connId q
+    void $ insertRcvQueue_ db connId q serverKeyHash_
 
 createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId)
 createSndConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} =
   createConn_ gVar cData $ \connId -> do
-    upsertServer_ db server
+    serverKeyHash_ <- createServer_ db server
     DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
-    void $ insertSndQueue_ db connId q
+    void $ insertSndQueue_ db connId q serverKeyHash_
 
 getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
 getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
@@ -445,8 +447,8 @@ addConnRcvQueue db connId rq =
 
 addConnRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO Int64
 addConnRcvQueue_ db connId rq@RcvQueue {server} = do
-  upsertServer_ db server
-  insertRcvQueue_ db connId rq
+  serverKeyHash_ <- createServer_ db server
+  insertRcvQueue_ db connId rq serverKeyHash_
 
 addConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
 addConnSndQueue db connId sq =
@@ -457,8 +459,8 @@ addConnSndQueue db connId sq =
 
 addConnSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO Int64
 addConnSndQueue_ db connId sq@SndQueue {server} = do
-  upsertServer_ db server
-  insertSndQueue_ db connId sq
+  serverKeyHash_ <- createServer_ db server
+  insertSndQueue_ db connId sq serverKeyHash_
 
 setRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO ()
 setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} status =
@@ -856,18 +858,21 @@ updateRatchet db connId rc skipped = do
         forM_ (M.assocs mks) $ \(msgN, mk) ->
           DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
 
-createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO AsyncCmdId
-createCommand db corrId connId srv cmd = do
-  DB.execute
-    db
-    "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command) VALUES (?,?,?,?,?,?)"
-    (host_, port_, corrId, connId, agentCommandTag cmd, cmd)
-  insertedRowId db
+createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO (Either StoreError AsyncCmdId)
+createCommand db corrId connId srv_ cmd = runExceptT $ do
+  (host_, port_, serverKeyHash_) <- serverFields
+  liftIO $ do
+    DB.execute
+      db
+      "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash) VALUES (?,?,?,?,?,?,?)"
+      (host_, port_, corrId, connId, agentCommandTag cmd, cmd, serverKeyHash_)
+    insertedRowId db
   where
-    (host_, port_) =
-      case srv of
-        Just (SMPServer host port _) -> (Just host, Just port)
-        _ -> (Nothing, Nothing)
+    serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash)
+    serverFields = case srv_ of
+      Just srv@(SMPServer host port _) ->
+        (Just host,Just port,) <$> ExceptT (getServerKeyHash_ db srv)
+      Nothing -> pure (Nothing, Nothing, Nothing)
 
 insertedRowId :: DB.Connection -> IO Int64
 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
@@ -878,7 +883,7 @@ getPendingCommands db connId = do
     <$> DB.query
       db
       [sql|
-        SELECT c.host, c.port, s.key_hash, c.command_id
+        SELECT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash), c.command_id
         FROM commands c
         LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
         WHERE conn_id = ?
@@ -1001,7 +1006,7 @@ getNtfSubscription db connId =
     DB.query
       db
       [sql|
-        SELECT s.host, s.port, s.key_hash, ns.ntf_host, ns.ntf_port, ns.ntf_key_hash,
+        SELECT s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash,
           nsb.smp_ntf_id, nsb.ntf_sub_id, nsb.ntf_sub_status, nsb.ntf_sub_action, nsb.ntf_sub_smp_action, nsb.ntf_sub_action_ts
         FROM ntf_subscriptions nsb
         JOIN servers s ON s.host = nsb.smp_host AND s.port = nsb.smp_port
@@ -1019,21 +1024,23 @@ getNtfSubscription db connId =
             _ -> Nothing
        in (NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}, action)
 
-createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
-createNtfSubscription db ntfSubscription action = do
-  let NtfSubscription {connId, smpServer = (SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} = ntfSubscription
+createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO (Either StoreError ())
+createNtfSubscription db ntfSubscription action = runExceptT $ do
+  let NtfSubscription {connId, smpServer = smpServer@(SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} = ntfSubscription
+  smpServerKeyHash_ <- ExceptT $ getServerKeyHash_ db smpServer
   actionTs <- liftIO getCurrentTime
-  DB.execute
-    db
-    [sql|
-      INSERT INTO ntf_subscriptions
-        (conn_id, smp_host, smp_port, smp_ntf_id, ntf_host, ntf_port, ntf_sub_id,
-          ntf_sub_status, ntf_sub_action, ntf_sub_smp_action, ntf_sub_action_ts)
-      VALUES (?,?,?,?,?,?,?,?,?,?,?)
-    |]
-    ( (connId, host, port, ntfQueueId, ntfHost, ntfPort, ntfSubId)
-        :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs)
-    )
+  liftIO $
+    DB.execute
+      db
+      [sql|
+        INSERT INTO ntf_subscriptions
+          (conn_id, smp_host, smp_port, smp_ntf_id, ntf_host, ntf_port, ntf_sub_id,
+            ntf_sub_status, ntf_sub_action, ntf_sub_smp_action, ntf_sub_action_ts, smp_server_key_hash)
+        VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
+      |]
+      ( (connId, host, port, ntfQueueId, ntfHost, ntfPort, ntfSubId)
+          :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, smpServerKeyHash_)
+      )
   where
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
@@ -1134,7 +1141,7 @@ getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) = do
       DB.query
         db
         [sql|
-          SELECT ns.conn_id, s.host, s.port, s.key_hash,
+          SELECT ns.conn_id, s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash),
             ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action
           FROM ntf_subscriptions ns
           JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port
@@ -1319,20 +1326,25 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
 
 {- ORMOLU_ENABLE -}
 
--- * Server upsert helper
+-- * Server helper
 
-upsertServer_ :: DB.Connection -> SMPServer -> IO ()
-upsertServer_ dbConn ProtocolServer {host, port, keyHash} = do
-  DB.executeNamed
-    dbConn
-    [sql|
-      INSERT INTO servers (host, port, key_hash) VALUES (:host,:port,:key_hash)
-      ON CONFLICT (host, port) DO UPDATE SET
-        host=excluded.host,
-        port=excluded.port,
-        key_hash=excluded.key_hash;
-    |]
-    [":host" := host, ":port" := port, ":key_hash" := keyHash]
+-- | Creates a new server, if it doesn't exist, and returns the passed key hash if it is different from stored.
+createServer_ :: DB.Connection -> SMPServer -> IO (Maybe C.KeyHash)
+createServer_ db newSrv@ProtocolServer {host, port, keyHash} =
+  getServerKeyHash_ db newSrv >>= \case
+    Right keyHash_ -> pure keyHash_
+    Left _ -> insertNewServer_ $> Nothing
+  where
+    insertNewServer_ =
+      DB.execute db "INSERT INTO servers (host, port, key_hash) VALUES (?,?,?)" (host, port, keyHash)
+
+-- | Returns the passed server key hash if it is different from the stored one, or the error if the server does not exist.
+getServerKeyHash_ :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe C.KeyHash))
+getServerKeyHash_ db ProtocolServer {host, port, keyHash} = do
+  firstRow useKeyHash SEServerNotFound $
+    DB.query db "SELECT key_hash FROM servers WHERE host = ? AND port = ?" (host, port)
+  where
+    useKeyHash (Only keyHash') = if keyHash /= keyHash' then Just keyHash else Nothing
 
 upsertNtfServer_ :: DB.Connection -> NtfServer -> IO ()
 upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
@@ -1349,30 +1361,30 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO Int64
-insertRcvQueue_ db connId' RcvQueue {..} = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> Maybe C.KeyHash -> IO Int64
+insertRcvQueue_ db connId' RcvQueue {..} serverKeyHash_ = do
   qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')
   DB.execute
     db
     [sql|
       INSERT INTO rcv_queues
-        (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);
+        (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
-    ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion))
+    ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
   pure qId
 
 -- * createSndConn helpers
 
-insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO Int64
-insertSndQueue_ db connId' SndQueue {..} = do
+insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> Maybe C.KeyHash -> IO Int64
+insertSndQueue_ db connId' SndQueue {..} serverKeyHash_ = do
   qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')
   DB.execute
     db
     [sql|
       INSERT INTO snd_queues
-        (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?);
+        (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
-    ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion))
+    ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
   pure qId
 
 newQueueId_ :: [Only Int64] -> Int64
@@ -1404,6 +1416,18 @@ getAnyConn deleted' dbConn connId =
           (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
           _ -> Left SEConnNotFound
 
+getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
+getConns = getAnyConns_ False
+
+getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
+getDeletedConns = getAnyConns_ True
+
+getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
+getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
+  where
+    handleDBError :: E.SomeException -> IO (Either StoreError SomeConn)
+    handleDBError = pure . Left . SEInternal . bshow
+
 getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
 getConnData dbConn connId' =
   maybeFirstRow cData $ DB.query dbConn "SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId')
@@ -1413,8 +1437,8 @@ getConnData dbConn connId' =
 setConnDeleted :: DB.Connection -> ConnId -> IO ()
 setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
 
-getDeletedConns :: DB.Connection -> IO [ConnId]
-getDeletedConns db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
+getDeletedConnIds :: DB.Connection -> IO [ConnId]
+getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
 
 -- | returns all connection queues, the first queue is the primary one
 getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
@@ -1429,7 +1453,7 @@ getRcvQueuesByConnId_ db connId =
 rcvQueueQuery :: Query
 rcvQueueQuery =
   [sql|
-    SELECT c.user_id, s.key_hash, q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
+    SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
       q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
       q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.delete_errors,
       q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
@@ -1463,7 +1487,7 @@ getSndQueuesByConnId_ dbConn connId =
     <$> DB.query
       dbConn
       [sql|
-        SELECT c.user_id, s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
+        SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
         FROM snd_queues q
         JOIN servers s ON q.host = s.host AND q.port = s.port
         JOIN connections c ON q.conn_id = c.conn_id

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

@@ -40,6 +40,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queu
 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.Encoding.String
 import Simplex.Messaging.Transport.Client (TransportHost)
 
@@ -59,7 +60,8 @@ schemaMigrations =
     ("m20220915_connection_queues", m20220915_connection_queues),
     ("m20230110_users", m20230110_users),
     ("m20230117_fkey_indexes", m20230117_fkey_indexes),
-    ("m20230120_delete_errors", m20230120_delete_errors)
+    ("m20230120_delete_errors", m20230120_delete_errors),
+    ("m20230217_server_key_hash", m20230217_server_key_hash)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+-- server_key_hash is not null for records whose entities refer to a server
+-- that was previously saved with the same host and port but different key hash
+m20230217_server_key_hash :: Query
+m20230217_server_key_hash =
+  [sql|
+ALTER TABLE rcv_queues ADD COLUMN server_key_hash BLOB;
+
+ALTER TABLE snd_queues ADD COLUMN server_key_hash BLOB;
+
+ALTER TABLE ntf_subscriptions ADD COLUMN smp_server_key_hash BLOB;
+
+ALTER TABLE commands ADD COLUMN server_key_hash BLOB;
+|]

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

@@ -48,6 +48,7 @@ CREATE TABLE rcv_queues(
   rcv_primary INTEGER CHECK(rcv_primary NOT NULL),
   replace_rcv_queue_id INTEGER NULL,
   delete_errors INTEGER DEFAULT 0 CHECK(delete_errors NOT NULL),
+  server_key_hash BLOB,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -68,6 +69,7 @@ CREATE TABLE snd_queues(
   snd_queue_id INTEGER CHECK(snd_queue_id NOT NULL),
   snd_primary INTEGER CHECK(snd_primary NOT NULL),
   replace_snd_queue_id INTEGER NULL,
+  server_key_hash BLOB,
   PRIMARY KEY(host, port, snd_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
@@ -199,6 +201,7 @@ CREATE TABLE ntf_subscriptions(
   updated_by_supervisor INTEGER NOT NULL DEFAULT 0, -- to be checked on updates by workers to not overwrite supervisor command(state still should be updated)
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  smp_server_key_hash BLOB,
   PRIMARY KEY(conn_id),
   FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port)
   ON DELETE SET NULL ON UPDATE CASCADE,
@@ -214,6 +217,7 @@ CREATE TABLE commands(
   command_tag BLOB NOT NULL,
   command BLOB NOT NULL,
   agent_version INTEGER NOT NULL DEFAULT 1,
+  server_key_hash BLOB,
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 );

src/Simplex/Messaging/Client.hs

@@ -55,6 +55,7 @@ module Simplex.Messaging.Client
 
     -- * Supporting types and client configuration
     ProtocolClientError (..),
+    SMPClientError,
     ProtocolClientConfig (..),
     NetworkConfig (..),
     TransportSessionMode (..),
@@ -62,7 +63,10 @@ module Simplex.Messaging.Client
     defaultNetworkConfig,
     transportClientConfig,
     chooseTransportHost,
+    proxyUsername,
+    temporaryClientError,
     ServerTransmission,
+    ClientCommand,
   )
 where
 
@@ -105,28 +109,28 @@ import System.Timeout (timeout)
 -- | 'SMPClient' is a handle used to send commands to a specific SMP server.
 --
 -- Use 'getSMPClient' to connect to an SMP server and create a client handle.
-data ProtocolClient msg = ProtocolClient
+data ProtocolClient err msg = ProtocolClient
   { action :: Maybe (Async ()),
     sessionId :: SessionId,
     sessionTs :: UTCTime,
     thVersion :: Version,
-    client_ :: PClient msg
+    client_ :: PClient err msg
   }
 
-data PClient msg = PClient
+data PClient err msg = PClient
   { connected :: TVar Bool,
     transportSession :: TransportSession msg,
     transportHost :: TransportHost,
     tcpTimeout :: Int,
     pingErrorCount :: TVar Int,
     clientCorrId :: TVar Natural,
-    sentCommands :: TMap CorrId (Request msg),
+    sentCommands :: TMap CorrId (Request err msg),
     sndQ :: TBQueue (NonEmpty SentRawTransmission),
-    rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
+    rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
     msgQ :: Maybe (TBQueue (ServerTransmission msg))
   }
 
-type SMPClient = ProtocolClient SMP.BrokerMsg
+type SMPClient = ProtocolClient ErrorType SMP.BrokerMsg
 
 -- | Type for client command data
 type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
@@ -229,14 +233,14 @@ defaultClientConfig =
       smpServerVRange = supportedSMPServerVRange
     }
 
-data Request msg = Request
+data Request err msg = Request
   { queueId :: QueueId,
-    responseVar :: TMVar (Response msg)
+    responseVar :: TMVar (Response err msg)
   }
 
-type Response msg = Either ProtocolClientError msg
+type Response err msg = Either (ProtocolClientError err) msg
 
-chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError TransportHost
+chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either (ProtocolClientError err) TransportHost
 chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
   firstOrError $ case hostMode of
     HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
@@ -250,15 +254,15 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts
     onionHost = find isOnionHost hosts
     publicHost = find (not . isOnionHost) hosts
 
-clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient msg -> String
+clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
 clientServer = B.unpack . strEncode . snd3 . transportSession . client_
   where
     snd3 (_, s, _) = s
 
-transportHost' :: ProtocolClient msg -> TransportHost
+transportHost' :: ProtocolClient err msg -> TransportHost
 transportHost' = transportHost . client_
 
-transportSession' :: ProtocolClient msg -> TransportSession msg
+transportSession' :: ProtocolClient err msg -> TransportSession msg
 transportSession' = transportSession . client_
 
 type UserId = Int64
@@ -271,7 +275,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall msg. Protocol msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
+getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
 getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
@@ -280,7 +284,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
     Left e -> pure $ Left e
   where
     NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
-    mkProtocolClient :: TransportHost -> STM (PClient msg)
+    mkProtocolClient :: TransportHost -> STM (PClient err msg)
     mkProtocolClient transportHost = do
       connected <- newTVar False
       pingErrorCount <- newTVar 0
@@ -302,7 +306,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
+    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient err msg -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
     runClient (port', ATransport t) useHost c = do
       cVar <- newEmptyTMVarIO
       let tcConfig = transportClientConfig networkConfig
@@ -317,18 +321,15 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
         Just (Left e) -> Left e
         Nothing -> Left PCENetworkError
 
-    proxyUsername :: TransportSession msg -> ByteString
-    proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
-
     useTransport :: (ServiceName, ATransport)
     useTransport = case port srv of
       "" -> defaultTransport cfg
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> PClient msg -> TMVar (Either ProtocolClientError (ProtocolClient msg)) -> c -> IO ()
+    client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO ()
     client _ c cVar h =
-      runExceptT (protocolClientHandshake @msg h (keyHash srv) smpServerVRange) >>= \case
+      runExceptT (protocolClientHandshake @err @msg h (keyHash srv) smpServerVRange) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {sessionId, thVersion} -> do
           sessionTs <- getCurrentTime
@@ -339,16 +340,16 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
           raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
             `finally` disconnected c'
 
-    send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
+    send :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
     send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
-    receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
+    receive :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
     receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
-    ping :: ProtocolClient msg -> IO ()
+    ping :: ProtocolClient err msg -> IO ()
     ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do
       threadDelay smpPingInterval
-      runExceptT (sendProtocolCommand c Nothing "" protocolPing) >>= \case
+      runExceptT (sendProtocolCommand c Nothing "" $ protocolPing @err @msg) >>= \case
         Left PCEResponseTimeout -> do
           cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1)
           when (maxCnt == 0 || cnt < maxCnt) $ ping c
@@ -356,10 +357,10 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
       where
         maxCnt = smpPingCount networkConfig
 
-    process :: ProtocolClient msg -> IO ()
+    process :: ProtocolClient err msg -> IO ()
     process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
 
-    processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
+    processMsg :: ProtocolClient err msg -> SignedTransmission err msg -> IO ()
     processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, qId, respOrErr)) =
       if B.null $ bs corrId
         then sendMsg respOrErr
@@ -377,23 +378,26 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
                       _ -> Right r
                   else Left . PCEUnexpectedResponse $ bshow respOrErr
       where
-        sendMsg :: Either ErrorType msg -> IO ()
+        sendMsg :: Either err msg -> IO ()
         sendMsg = \case
           Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
           Left e -> putStrLn $ "SMP client error: " <> show e
 
+proxyUsername :: TransportSession msg -> ByteString
+proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
+
 -- | Disconnects client from the server and terminates client threads.
-closeProtocolClient :: ProtocolClient msg -> IO ()
+closeProtocolClient :: ProtocolClient err msg -> IO ()
 closeProtocolClient = mapM_ uninterruptibleCancel . action
 
 -- | SMP client error type.
-data ProtocolClientError
+data ProtocolClientError err
   = -- | Correctly parsed SMP server ERR response.
     -- This error is forwarded to the agent client as `ERR SMP err`.
-    PCEProtocolError ErrorType
+    PCEProtocolError err
   | -- | Invalid server response that failed to parse.
     -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
-    PCEResponseError ErrorType
+    PCEResponseError err
   | -- | Different response from what is expected to a certain SMP command,
     -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
     -- other responses would result in this error.
@@ -410,12 +414,21 @@ data ProtocolClientError
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
-  | -- | Error when cryptographically "signing" the command.
-    PCESignatureError C.CryptoError
+  | -- | Error when cryptographically "signing" the command or when initializing crypto_box.
+    PCECryptoError C.CryptoError
   | -- | IO Error
     PCEIOError IOException
   deriving (Eq, Show, Exception)
 
+type SMPClientError = ProtocolClientError ErrorType
+
+temporaryClientError :: ProtocolClientError err -> Bool
+temporaryClientError = \case
+  PCENetworkError -> True
+  PCEResponseTimeout -> True
+  PCEIOError _ -> True
+  _ -> False
+
 -- | Create a new SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
@@ -425,7 +438,7 @@ createSMPQueue ::
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
   Maybe BasicAuth ->
-  ExceptT ProtocolClientError IO QueueIdsKeys
+  ExceptT SMPClientError IO QueueIdsKeys
 createSMPQueue c rpKey rKey dhKey auth =
   sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
     IDS qik -> pure qik
@@ -434,7 +447,7 @@ createSMPQueue c rpKey rKey dhKey auth =
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
+subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
 subscribeSMPQueue c rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
@@ -442,7 +455,7 @@ subscribeSMPQueue c rpKey rId =
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Subscribe to multiple SMP queues batching commands if supported.
-subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
+subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
   where
     cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
@@ -455,14 +468,14 @@ subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
 writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
 writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
 
-serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
+serverTransmission :: ProtocolClient err msg -> RecipientId -> msg -> ServerTransmission msg
 serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {transportSession}} entityId message =
   (transportSession, thVersion, sessionId, entityId, message)
 
 -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
 --
 -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
-getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe RcvMessage)
+getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
 getSMPMessage c rpKey rId =
   sendSMPCommand c (Just rpKey) rId GET >>= \case
     OK -> pure Nothing
@@ -472,26 +485,26 @@ getSMPMessage c rpKey rId =
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT ProtocolClientError IO ()
+subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
 subscribeSMPQueueNotifications = okSMPCommand NSUB
 
 -- | Secure the SMP queue by adding a sender public key.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
-secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError IO ()
+secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
 secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
 
 -- | Enable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
-enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT ProtocolClientError IO (NotifierId, RcvNtfPublicDhKey)
+enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
 enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
   sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
     NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Enable notifications for the multiple queues for push notifications server.
-enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
+enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
 enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
   where
     cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
@@ -503,17 +516,17 @@ enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
 -- | Disable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
-disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
+disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
 disableSMPQueueNotifications = okSMPCommand NDEL
 
 -- | Disable notifications for multiple queues for push notifications server.
-disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
+disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 disableSMPQueuesNtfs = okSMPCommands NDEL
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT ProtocolClientError IO ()
+sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
 sendSMPMessage c spKey sId flags msg =
   sendSMPCommand c spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
@@ -522,7 +535,7 @@ sendSMPMessage c spKey sId flags msg =
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
+ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
 ackSMPMessage c rpKey rId msgId =
   sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
@@ -533,26 +546,26 @@ ackSMPMessage c rpKey rId msgId =
 -- The existing messages from the queue will still be delivered.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
-suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 suspendSMPQueue = okSMPCommand OFF
 
 -- | Irreversibly delete SMP queue and all messages in it.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
-deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 
 -- | Delete multiple SMP queues batching commands if supported.
-deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
+deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 deleteSMPQueues = okSMPCommands DEL
 
-okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either ProtocolClientError ()))
+okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
 okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs
   where
     aCmd = Cmd sParty cmd
@@ -563,11 +576,11 @@ okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs
       Left e -> Left e
 
 -- | Send SMP command
-sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
+sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
 sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
 -- | Send multiple commands with batching and collect responses
-sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
+sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either (ProtocolClientError err) msg))
 sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ}} cs = do
   ts <- mapM (runExceptT . mkTransmission c) cs
   mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
@@ -576,22 +589,22 @@ sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ}} cs = do
     Left e -> pure $ Left e
 
 -- | Send Protocol command
-sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
+sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
 sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}} pKey qId cmd = do
   (t, r) <- mkTransmission c (pKey, qId, cmd)
   ExceptT $ sendRecv t r
   where
     -- two separate "atomically" needed to avoid blocking
-    sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
+    sendRecv :: SentRawTransmission -> TMVar (Response err msg) -> IO (Response err msg)
     sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c (atomically $ takeTMVar r)
 
-withTimeout :: ProtocolClient msg -> IO (Either ProtocolClientError msg) -> IO (Either ProtocolClientError msg)
+withTimeout :: ProtocolClient err msg -> IO (Either (ProtocolClientError err) msg) -> IO (Either (ProtocolClientError err) msg)
 withTimeout ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} a =
   timeout tcpTimeout a >>= \case
     Just r -> atomically (writeTVar pingErrorCount 0) >> pure r
     _ -> pure $ Left PCEResponseTimeout
 
-mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
+mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> ExceptT (ProtocolClientError err) IO (SentRawTransmission, TMVar (Response err msg))
 mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do
   corrId <- liftIO $ atomically getNextCorrId
   let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
@@ -604,7 +617,7 @@ mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCo
       pure . CorrId $ bshow i
     signTransmission :: ByteString -> SentRawTransmission
     signTransmission t = ((`C.sign` t) <$> pKey, t)
-    mkRequest :: CorrId -> STM (TMVar (Response msg))
+    mkRequest :: CorrId -> STM (TMVar (Response err msg))
     mkRequest corrId = do
       r <- newEmptyTMVar
       TM.insert corrId (Request qId r) sentCommands

src/Simplex/Messaging/Client/Agent.hs

@@ -38,14 +38,14 @@ import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-type SMPClientVar = TMVar (Either ProtocolClientError SMPClient)
+type SMPClientVar = TMVar (Either SMPClientError SMPClient)
 
 data SMPClientAgentEvent
   = CAConnected SMPServer
   | CADisconnected SMPServer (Set SMPSub)
   | CAReconnected SMPServer
   | CAResubscribed SMPServer SMPSub
-  | CASubError SMPServer SMPSub ProtocolClientError
+  | CASubError SMPServer SMPSub SMPClientError
 
 data SMPSubParty = SPRecipient | SPNotifier
   deriving (Eq, Ord, Show)
@@ -111,7 +111,7 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
   asyncClients <- newTVar []
   pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
 
-getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT ProtocolClientError IO SMPClient
+getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
 getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
   atomically getClientVar >>= either newSMPClient waitForSMPClient
   where
@@ -124,7 +124,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
       TM.insert srv smpVar smpClients
       pure smpVar
 
-    waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
+    waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
     waitForSMPClient smpVar = do
       let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
       smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
@@ -133,10 +133,10 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
         Just (Left e) -> Left e
         Nothing -> Left PCEResponseTimeout
 
-    newSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
+    newSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
     newSMPClient smpVar = tryConnectClient pure tryConnectAsync
       where
-        tryConnectClient :: (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO () -> ExceptT ProtocolClientError IO a
+        tryConnectClient :: (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO () -> ExceptT SMPClientError IO a
         tryConnectClient successAction retryAction =
           tryE connectClient >>= \r -> case r of
             Right smp -> do
@@ -150,16 +150,16 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
                   putTMVar smpVar (Left e)
                   TM.delete srv smpClients
               throwE e
-        tryConnectAsync :: ExceptT ProtocolClientError IO ()
+        tryConnectAsync :: ExceptT SMPClientError IO ()
         tryConnectAsync = do
           a <- async connectAsync
           atomically $ modifyTVar' (asyncClients ca) (a :)
-        connectAsync :: ExceptT ProtocolClientError IO ()
+        connectAsync :: ExceptT SMPClientError IO ()
         connectAsync =
           withRetryInterval (reconnectInterval agentCfg) $ \loop ->
             void $ tryConnectClient (const reconnectClient) loop
 
-    connectClient :: ExceptT ProtocolClientError IO SMPClient
+    connectClient :: ExceptT SMPClientError IO SMPClient
     connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
     clientDisconnected :: SMPClient -> IO ()
@@ -188,17 +188,17 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
       notify . CADisconnected srv $ M.keysSet ss
       reconnectServer
 
-    reconnectServer :: ExceptT ProtocolClientError IO ()
+    reconnectServer :: ExceptT SMPClientError IO ()
     reconnectServer = do
       a <- async tryReconnectClient
       atomically $ modifyTVar' (reconnections ca) (a :)
 
-    tryReconnectClient :: ExceptT ProtocolClientError IO ()
+    tryReconnectClient :: ExceptT SMPClientError IO ()
     tryReconnectClient = do
       withRetryInterval (reconnectInterval agentCfg) $ \loop ->
         reconnectClient `catchE` const loop
 
-    reconnectClient :: ExceptT ProtocolClientError IO ()
+    reconnectClient :: ExceptT SMPClientError IO ()
     reconnectClient = do
       withSMP ca srv $ \smp -> do
         notify $ CAReconnected srv
@@ -207,13 +207,13 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
           unlessM (atomically $ hasSub (srvSubs ca) srv s) $
             subscribe_ smp sub `catchE` handleError s
       where
-        subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
+        subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
         subscribe_ smp sub@(s, _) = do
           smpSubscribe smp sub
           atomically $ addSubscription ca srv sub
           notify $ CAResubscribed srv s
 
-        handleError :: SMPSub -> ProtocolClientError -> ExceptT ProtocolClientError IO ()
+        handleError :: SMPSub -> SMPClientError -> ExceptT SMPClientError IO ()
         handleError s = \case
           e@PCEResponseTimeout -> throwE e
           e@PCENetworkError -> throwE e
@@ -221,7 +221,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
             notify $ CASubError srv s e
             atomically $ removePendingSubscription ca srv s
 
-    notify :: SMPClientAgentEvent -> ExceptT ProtocolClientError IO ()
+    notify :: SMPClientAgentEvent -> ExceptT SMPClientError IO ()
     notify evt = atomically $ writeTBQueue (agentQ ca) evt
 
 closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
@@ -241,15 +241,15 @@ closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeCli
 cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
 cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
 
-withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO a
+withSMP :: SMPClientAgent -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO a
 withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPError
   where
-    logSMPError :: ProtocolClientError -> ExceptT ProtocolClientError IO a
+    logSMPError :: SMPClientError -> ExceptT SMPClientError IO a
     logSMPError e = do
       liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
       throwE e
 
-subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
+subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
 subscribeQueue ca srv sub = do
   atomically $ addPendingSubscription ca srv sub
   withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleError
@@ -267,7 +267,7 @@ showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)
 
-smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
+smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
 smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
   where
     subscribe_ = case party of

src/Simplex/Messaging/Crypto.hs

@@ -91,18 +91,23 @@ module Simplex.Messaging.Crypto
     -- * AES256 AEAD-GCM scheme
     Key (..),
     IV (..),
+    GCMIV (unGCMIV), -- constructor is not exported
     AuthTag (..),
-    encryptAES,
-    decryptAES,
     encryptAEAD,
     decryptAEAD,
+    encryptAESNoPad,
+    decryptAESNoPad,
     authTagSize,
     randomAesKey,
     randomIV,
+    randomGCMIV,
     ivSize,
+    gcmIVSize,
+    gcmIV,
 
     -- * NaCl crypto_box
     CbNonce (unCbNonce),
+    pattern CbNonce,
     cbEncrypt,
     cbEncryptMaxLenBS,
     cbDecrypt,
@@ -110,10 +115,19 @@ module Simplex.Messaging.Crypto
     randomCbNonce,
     pseudoRandomCbNonce,
 
+    -- * NaCl crypto_secretbox
+    SbKey (unSbKey),
+    pattern SbKey,
+    sbEncrypt,
+    sbDecrypt,
+    sbKey,
+    unsafeSbKey,
+    randomSbKey,
+
     -- * pseudo-random bytes
     pseudoRandomBytes,
 
-    -- * SHA256 hash
+    -- * hash
     sha256Hash,
 
     -- * Message padding / un-padding
@@ -140,7 +154,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
@@ -153,12 +167,12 @@ import Data.ASN1.Types
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (bimap, first)
+import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
 import Data.ByteString.Base64 (decode, encode)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.ByteString.Internal (c2w, w2c)
 import Data.ByteString.Lazy (fromStrict, toStrict)
 import Data.Constraint (Dict (..))
 import Data.Kind (Constraint, Type)
@@ -690,6 +704,8 @@ data CryptoError
     AESDecryptError
   | -- CryptoBox decryption error
     CBDecryptError
+  | -- Poly1305 initialization error
+    CryptoPoly1305Error CE.CryptoError
   | -- | message is larger that allowed padded length minus 2 (to prepend message length)
     -- (or required un-padded length is larger than the message length)
     CryptoLargeMsgError
@@ -742,16 +758,32 @@ instance FromJSON Key where
 
 -- | IV bytes newtype.
 newtype IV = IV {unIV :: ByteString}
+  deriving (Eq, Show)
 
 instance Encoding IV where
   smpEncode = unIV
   smpP = IV <$> A.take (ivSize @AES256)
 
+instance ToJSON IV where
+  toJSON = strToJSON . unIV
+  toEncoding = strToJEncoding . unIV
+
+instance FromJSON IV where
+  parseJSON = fmap IV . strParseJSON "IV"
+
+-- | GCMIV bytes newtype.
+newtype GCMIV = GCMIV {unGCMIV :: ByteString}
+
+gcmIV :: ByteString -> Either CryptoError GCMIV
+gcmIV s
+  | B.length s == gcmIVSize = Right $ GCMIV s
+  | otherwise = Left CryptoIVError
+
 newtype AuthTag = AuthTag {unAuthTag :: AES.AuthTag}
 
 instance Encoding AuthTag where
-  smpEncode = B.pack . map w2c . BA.unpack . AES.unAuthTag . unAuthTag
-  smpP = AuthTag . AES.AuthTag . BA.pack . map c2w . B.unpack <$> A.take authTagSize
+  smpEncode = BA.convert . unAuthTag
+  smpP = AuthTag . AES.AuthTag . BA.convert <$> A.take authTagSize
 
 -- | Certificate fingerpint newtype.
 --
@@ -777,35 +809,48 @@ instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
 sha256Hash :: ByteString -> ByteString
 sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)
 
--- | AEAD-GCM encryption with empty associated data.
+-- | AEAD-GCM encryption with associated data.
 --
--- Used as part of hybrid E2E encryption scheme and for SMP transport blocks encryption.
-encryptAES :: Key -> IV -> Int -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
-encryptAES key iv paddedLen = encryptAEAD key iv paddedLen ""
-
--- | AEAD-GCM encryption.
---
--- Used as part of hybrid E2E encryption scheme and for SMP transport blocks encryption.
+-- Used as part of double ratchet encryption.
+-- This function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
+-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
 encryptAEAD :: Key -> IV -> Int -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
 encryptAEAD aesKey ivBytes paddedLen ad msg = do
   aead <- initAEAD @AES256 aesKey ivBytes
   msg' <- liftEither $ pad msg paddedLen
   pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg' authTagSize
 
--- | AEAD-GCM decryption with empty associated data.
---
--- Used as part of hybrid E2E encryption scheme and for SMP transport blocks decryption.
-decryptAES :: Key -> IV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
-decryptAES key iv = decryptAEAD key iv ""
+-- Used to encrypt WebRTC frames.
+-- This function requires 12 bytes IV, it does not transform IV.
+encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
+encryptAESNoPad key iv = encryptAEADNoPad key iv ""
 
--- | AEAD-GCM decryption.
+encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
+encryptAEADNoPad aesKey ivBytes ad msg = do
+  aead <- initAEADGCM aesKey ivBytes
+  pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize
+
+-- | AEAD-GCM decryption with associated data.
 --
--- Used as part of hybrid E2E encryption scheme and for SMP transport blocks decryption.
+-- Used as part of double ratchet encryption.
+-- This function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
+-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
+-- To make it compatible with WebCrypto we will need to start using initAEADGCM.
 decryptAEAD :: Key -> IV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
 decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
   aead <- initAEAD @AES256 aesKey ivBytes
   liftEither . unPad =<< maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg authTag)
 
+-- Used to decrypt WebRTC frames.
+-- This function requires 12 bytes IV, it does not transform IV.
+decryptAESNoPad :: Key -> GCMIV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
+decryptAESNoPad key iv = decryptAEADNoPad key iv ""
+
+decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
+decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
+  aead <- initAEADGCM aesKey iv
+  maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg tag)
+
 maxMsgLen :: Int
 maxMsgLen = 2 ^ (16 :: Int) - 3
 
@@ -860,6 +905,9 @@ appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
 maxLength :: forall i. KnownNat i => Int
 maxLength = fromIntegral (natVal $ Proxy @i)
 
+-- this function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
+-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
+-- This is used for double ratchet encryption, so to make it compatible with WebCrypto we will need to deprecate it and start using initAEADGCM
 initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
 initAEAD (Key aesKey) (IV ivBytes) = do
   iv <- makeIV @c ivBytes
@@ -867,6 +915,12 @@ initAEAD (Key aesKey) (IV ivBytes) = do
     cipher <- AES.cipherInit aesKey
     AES.aeadInit AES.AEAD_GCM cipher iv
 
+-- this function requires 12 bytes IV, it does not transforms IV.
+initAEADGCM :: Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD AES256)
+initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
+  cipher <- AES.cipherInit aesKey
+  AES.aeadInit AES.AEAD_GCM cipher ivBytes
+
 -- | Random AES256 key.
 randomAesKey :: IO Key
 randomAesKey = Key <$> getRandomBytes aesKeySize
@@ -875,9 +929,15 @@ randomAesKey = Key <$> getRandomBytes aesKeySize
 randomIV :: IO IV
 randomIV = IV <$> getRandomBytes (ivSize @AES256)
 
+randomGCMIV :: IO GCMIV
+randomGCMIV = GCMIV <$> getRandomBytes gcmIVSize
+
 ivSize :: forall c. AES.BlockCipher c => Int
 ivSize = AES.blockSize (undefined :: c)
 
+gcmIVSize :: Int
+gcmIVSize = 12
+
 makeIV :: AES.BlockCipher c => ByteString -> ExceptT CryptoError IO (AES.IV c)
 makeIV bs = maybeError CryptoIVError $ AES.makeIV bs
 
@@ -915,13 +975,20 @@ dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
 
 -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
 cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
-cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
+cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret
+
+-- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce.
+sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
+sbEncrypt (SbKey key) = sbEncrypt_ key
+
+sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
+sbEncrypt_ secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
 
 -- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
 cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
-cbEncryptMaxLenBS secret (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
+cbEncryptMaxLenBS (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
 
-cryptoBox :: DhSecret 'X25519 -> ByteString -> ByteString -> ByteString
+cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString
 cryptoBox secret nonce s = BA.convert tag <> c
   where
     (rs, c) = xSalsa20 secret nonce s
@@ -929,7 +996,15 @@ cryptoBox secret nonce s = BA.convert tag <> c
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
 cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
-cbDecrypt secret (CbNonce nonce) packet
+cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret
+
+-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
+sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
+sbDecrypt (SbKey key) = sbDecrypt_ key
+
+-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
+sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
+sbDecrypt_ secret (CbNonce nonce) packet
   | B.length packet < 16 = Left CBDecryptError
   | BA.constEq tag' tag = unPad msg
   | otherwise = Left CBDecryptError
@@ -938,9 +1013,14 @@ cbDecrypt secret (CbNonce nonce) packet
     (rs, msg) = xSalsa20 secret nonce c
     tag = Poly1305.auth rs c
 
-newtype CbNonce = CbNonce {unCbNonce :: ByteString}
+newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
   deriving (Eq, Show)
 
+pattern CbNonce :: ByteString -> CbNonce
+pattern CbNonce s <- CryptoBoxNonce s
+
+{-# COMPLETE CbNonce #-}
+
 instance StrEncoding CbNonce where
   strEncode (CbNonce s) = strEncode s
   strP = cbNonce <$> strP
@@ -949,33 +1029,66 @@ instance ToJSON CbNonce where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance FromJSON CbNonce where
+  parseJSON = strParseJSON "CbNonce"
+
 cbNonce :: ByteString -> CbNonce
 cbNonce s
-  | len == 24 = CbNonce s
-  | len > 24 = CbNonce . fst $ B.splitAt 24 s
-  | otherwise = CbNonce $ s <> B.replicate (24 - len) (toEnum 0)
+  | len == 24 = CryptoBoxNonce s
+  | len > 24 = CryptoBoxNonce . fst $ B.splitAt 24 s
+  | otherwise = CryptoBoxNonce $ s <> B.replicate (24 - len) (toEnum 0)
   where
     len = B.length s
 
 randomCbNonce :: IO CbNonce
-randomCbNonce = CbNonce <$> getRandomBytes 24
+randomCbNonce = CryptoBoxNonce <$> getRandomBytes 24
 
 pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
-pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar
+pseudoRandomCbNonce gVar = CryptoBoxNonce <$> pseudoRandomBytes 24 gVar
 
 pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
 pseudoRandomBytes n gVar = stateTVar gVar $ randomBytesGenerate n
 
 instance Encoding CbNonce where
   smpEncode = unCbNonce
-  smpP = CbNonce <$> A.take 24
+  smpP = CryptoBoxNonce <$> A.take 24
 
-xSalsa20 :: DhSecret X25519 -> ByteString -> ByteString -> (ByteString, ByteString)
-xSalsa20 (DhSecretX25519 shared) nonce msg = (rs, msg')
+newtype SbKey = SecretBoxKey {unSbKey :: ByteString}
+  deriving (Eq, Show)
+
+pattern SbKey :: ByteString -> SbKey
+pattern SbKey s <- SecretBoxKey s
+
+{-# COMPLETE SbKey #-}
+
+instance StrEncoding SbKey where
+  strEncode (SbKey s) = strEncode s
+  strP = sbKey <$?> strP
+
+instance ToJSON SbKey where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON SbKey where
+  parseJSON = strParseJSON "SbKey"
+
+sbKey :: ByteString -> Either String SbKey
+sbKey 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
+
+xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
+xSalsa20 secret nonce msg = (rs, msg')
   where
     zero = B.replicate 16 $ toEnum 0
     (iv0, iv1) = B.splitAt 8 nonce
-    state0 = XSalsa.initialize 20 shared (zero `B.append` iv0)
+    state0 = XSalsa.initialize 20 secret (zero `B.append` iv0)
     state1 = XSalsa.derive state0 iv1
     (rs, state2) = XSalsa.generate state1 32
     (msg', _) = XSalsa.combine state2 msg

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -0,0 +1,186 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Crypto.Lazy
+  ( sha256Hash,
+    sha512Hash,
+    pad,
+    unPad,
+    sbEncrypt,
+    sbDecrypt,
+    sbEncryptTailTag,
+    sbDecryptTailTag,
+    fastReplicate,
+    SbState,
+    cbInit,
+    sbInit,
+    sbEncryptChunk,
+    sbDecryptChunk,
+    sbAuth,
+  )
+where
+
+import qualified Crypto.Cipher.XSalsa as XSalsa
+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.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 (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
+import Simplex.Messaging.Encoding
+
+type LazyByteString = LB.ByteString
+
+-- | SHA512 digest of a lazy bytestring.
+sha256Hash :: LazyByteString -> ByteString
+sha256Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA256)
+
+-- | SHA512 digest of a lazy bytestring.
+sha512Hash :: LazyByteString -> ByteString
+sha512Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA512)
+
+-- this function does not validate the length of the message to avoid consuming all chunks,
+-- but if the passed string is longer it will truncate it to specified length
+pad :: LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
+pad msg len paddedLen
+  | padLen >= 0 = Right $ LB.fromStrict encodedLen <> LB.take len msg <> fastReplicate padLen '#'
+  | otherwise = Left CryptoLargeMsgError
+  where
+    encodedLen = smpEncode len -- 8 bytes Int64 encoded length
+    padLen = paddedLen - len - 8
+
+fastReplicate :: Int64 -> Char -> LazyByteString
+fastReplicate n c
+  | n <= 0 = LB.empty
+  | n < chSize' = LB.fromStrict $ B.replicate (fromIntegral n) c
+  | otherwise = LB.fromChunks $ B.replicate (fromIntegral r) c : replicate (fromIntegral q) chPad
+  where
+    chSize = 65536 - 2 * sizeOf (undefined :: Int)
+    chPad = B.replicate chSize c
+    chSize' = fromIntegral chSize
+    (q, r) = quotRem n chSize'
+
+-- 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
+  | LB.length lenStr == 8 = case smpDecode $ LB.toStrict lenStr of
+    Right len
+      | len < 0 -> Left CryptoInvalidMsgError
+      | otherwise -> Right $ LB.take len rest
+    Left _ -> Left CryptoInvalidMsgError
+  | otherwise = Left CryptoInvalidMsgError
+  where
+    (lenStr, rest) = LB.splitAt 8 padded
+
+-- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce.
+-- The resulting string will be bigger than paddedLen by the size of the auth tag (16 bytes).
+sbEncrypt :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
+sbEncrypt (SbKey key) (CbNonce nonce) msg len paddedLen =
+  prependTag <$> (secretBox sbEncryptChunk key nonce =<< pad msg len paddedLen)
+  where
+    prependTag (tag :| cs) = LB.Chunk tag $ LB.fromChunks cs
+
+-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
+-- The resulting string will be smaller than packet size by the size of the auth tag (16 bytes).
+sbDecrypt :: SbKey -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString
+sbDecrypt (SbKey key) (CbNonce nonce) packet
+  | LB.length tag' < 16 = Left CBDecryptError
+  | 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
+
+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
+
+-- | 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
+    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 :: 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 #-}

src/Simplex/Messaging/Encoding/String.hs

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

src/Simplex/Messaging/Notifications/Client.hs

@@ -10,54 +10,57 @@ import Data.Word (Word16)
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Protocol (ErrorType)
 import Simplex.Messaging.Util (bshow)
 
-type NtfClient = ProtocolClient NtfResponse
+type NtfClient = ProtocolClient ErrorType NtfResponse
 
-ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
+type NtfClientError = ProtocolClientError ErrorType
+
+ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
 ntfRegisterToken c pKey newTkn =
   sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
+ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
 ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
 
-ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO NtfTknStatus
+ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
 ntfCheckToken c pKey tknId =
   sendNtfCommand c (Just pKey) tknId TCHK >>= \case
     NRTkn stat -> pure stat
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT ProtocolClientError IO ()
+ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
 ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
 
-ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
+ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO ()
 ntfDeleteToken = okNtfCommand TDEL
 
-ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
+ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
 ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
 
-ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO NtfSubscriptionId
+ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
 ntfCreateSubscription c pKey newSub =
   sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
     NRSubId subId -> pure subId
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
+ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
 ntfCheckSubscription c pKey subId =
   sendNtfCommand c (Just pKey) subId SCHK >>= \case
     NRSub stat -> pure stat
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
+ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
 ntfDeleteSubscription = okNtfCommand SDEL
 
 -- | Send notification server command
-sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT ProtocolClientError IO NtfResponse
+sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
 sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
 
-okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT ProtocolClientError IO ()
+okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT NtfClientError IO ()
 okNtfCommand cmd c pKey entId =
   sendNtfCommand c (Just pKey) entId cmd >>= \case
     NROk -> return ()

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -146,7 +147,7 @@ instance Encoding ANewNtfEntity where
       'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP <*> smpP)
       _ -> fail "bad ANewNtfEntity"
 
-instance Protocol NtfResponse where
+instance Protocol ErrorType NtfResponse where
   type ProtoCommand NtfResponse = NtfCmd
   type ProtoType NtfResponse = 'PNTF
   protocolClientHandshake = ntfClientHandshake
@@ -183,7 +184,7 @@ data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
 
 deriving instance Show NtfCmd
 
-instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
+instance NtfEntityI e => ProtocolEncoding ErrorType (NtfCommand e) where
   type Tag (NtfCommand e) = NtfCommandTag e
   encodeProtocol _v = \case
     TNEW newTkn -> e (TNEW_, ' ', newTkn)
@@ -202,6 +203,9 @@ instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
 
   protocolP _v tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP _v (NCT (sNtfEntity @e) tag)
 
+  fromProtocolError = fromProtocolError @ErrorType @NtfResponse
+  {-# INLINE fromProtocolError #-}
+
   checkCredentials (sig, _, entityId, _) cmd = case cmd of
     -- TNEW and SNEW must have signature but NOT token/subscription IDs
     TNEW {} -> sigNoEntity
@@ -219,7 +223,7 @@ instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
         | not (B.null entityId) = Left $ CMD HAS_AUTH
         | otherwise = Right cmd
 
-instance ProtocolEncoding NtfCmd where
+instance ProtocolEncoding ErrorType NtfCmd where
   type Tag NtfCmd = NtfCmdTag
   encodeProtocol _v (NtfCmd _ c) = encodeProtocol _v c
 
@@ -239,6 +243,9 @@ instance ProtocolEncoding NtfCmd where
         SDEL_ -> pure SDEL
         PING_ -> pure PING
 
+  fromProtocolError = fromProtocolError @ErrorType @NtfResponse
+  {-# INLINE fromProtocolError #-}
+
   checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
 
 data NtfResponseTag
@@ -283,7 +290,7 @@ data NtfResponse
   | NRPong
   deriving (Show)
 
-instance ProtocolEncoding NtfResponse where
+instance ProtocolEncoding ErrorType NtfResponse where
   type Tag NtfResponse = NtfResponseTag
   encodeProtocol _v = \case
     NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey)
@@ -306,6 +313,13 @@ instance ProtocolEncoding NtfResponse where
     NRSub_ -> NRSub <$> _smpP
     NRPong_ -> pure NRPong
 
+  fromProtocolError = \case
+    PECmdSyntax -> CMD SYNTAX
+    PECmdUnknown -> CMD UNKNOWN
+    PESession -> SESSION
+    PEBlock -> BLOCK
+  {-# INLINE fromProtocolError #-}
+
   checkCredentials (_, _, entId, _) cmd = case cmd of
     -- IDTKN response must not have queue ID
     NRTknId {} -> noEntity

src/Simplex/Messaging/Notifications/Server.hs

@@ -27,7 +27,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Network.Socket (ServiceName)
-import Simplex.Messaging.Client (ProtocolClientError (..))
+import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError)
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -227,7 +227,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       where
         showServer' = decodeLatin1 . strEncode . host
 
-    handleSubError :: SMPQueueNtf -> ProtocolClientError -> M ()
+    handleSubError :: SMPQueueNtf -> SMPClientError -> M ()
     handleSubError smpQueue = \case
       PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
       PCEProtocolError e -> updateErr "SMP error " e
@@ -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 ()
@@ -319,7 +319,7 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte
 
 receive :: Transport c => THandle c -> NtfServerClient -> M ()
 receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
-  ts <- tGet th
+  ts <- liftIO $ tGet th
   forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
     atomically . writeTVar activeAt =<< liftIO getSystemTime
     logDebug "received transmission"
@@ -343,7 +343,7 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = for
 
 data VerificationResult = VRVerified NtfRequest | VRFailed
 
-verifyNtfTransmission :: SignedTransmission NtfCmd -> NtfCmd -> M VerificationResult
+verifyNtfTransmission :: SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
 verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
   st <- asks store
   case cmd of

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

@@ -32,10 +32,12 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.CaseInsensitive as CI
 import Data.Int (Int64)
 import Data.Map.Strict (Map)
+import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock.System
 import qualified Data.X509 as X
+import qualified Data.X509.CertificateStore as XS
 import GHC.Generics (Generic)
 import Network.HTTP.Types (HeaderName, Status)
 import qualified Network.HTTP.Types as N
@@ -47,6 +49,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
 import Simplex.Messaging.Protocol (EncNMsgMeta)
+import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Environment (getEnv)
@@ -97,8 +100,8 @@ readECPrivateKey f = do
 data PushNotification
   = PNVerification NtfRegCode
   | PNMessage PNMessageData
-  -- | PNAlert Text
-  | PNCheckMessages
+  | -- | PNAlert Text
+    PNCheckMessages
   deriving (Show)
 
 data PNMessageData = PNMessageData
@@ -194,9 +197,9 @@ data APNSPushClientConfig = APNSPushClientConfig
     appName :: ByteString,
     appTeamId :: Text,
     apnsPort :: ServiceName,
-    http2cfg :: HTTP2ClientConfig
+    http2cfg :: HTTP2ClientConfig,
+    caStoreFile :: FilePath
   }
-  deriving (Show)
 
 apnsProviderHost :: PushProvider -> HostName
 apnsProviderHost = \case
@@ -215,7 +218,8 @@ defaultAPNSPushClientConfig =
       appName = "chat.simplex.app",
       appTeamId = "5NN7GUYB6T",
       apnsPort = "443",
-      http2cfg = defaultHTTP2ClientConfig
+      http2cfg = defaultHTTP2ClientConfig {bufferSize = 16384},
+      caStoreFile = "/etc/ssl/cert.pem"
     }
 
 data APNSPushClient = APNSPushClient
@@ -259,8 +263,10 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
   pure (jwt, signedJWT)
 
 connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
-connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client = do
-  r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
+connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg, caStoreFile} https2Client = do
+  caStore_ <- XS.readCertificateStore caStoreFile
+  when (isNothing caStore_) $ putStrLn $ "Error loading CertificateStore from " <> caStoreFile
+  r <- getHTTP2Client apnsHost apnsPort caStore_ http2cfg disconnected
   case r of
     Right client -> atomically . writeTVar https2Client $ Just client
     Left e -> putStrLn $ "Error connecting to APNS: " <> show e
@@ -294,7 +300,8 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
     encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
     apn aps notificationData = APNSNotification {aps, notificationData}
     apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or another app event", category = Just ntfCategoryCheckMessage}
-    -- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
+
+-- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
 
 apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
 apnsRequest c tkn ntf@APNSNotification {aps} = do
@@ -336,9 +343,10 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
   nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
   apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
   req <- liftIO $ apnsRequest c tknStr apnsNtf
-  HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
+  -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
+  HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing
   let status = H.responseStatus response
-      reason' = maybe "" reason $ J.decodeStrict' respBody
+      reason' = maybe "" reason $ J.decodeStrict' bodyHead
   logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
   result status reason'
   where

src/Simplex/Messaging/Protocol.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -19,11 +20,10 @@
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# HLINT ignore "Use newtype instead of data" #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
-{-# HLINT ignore "Use newtype instead of data" #-}
-
 -- |
 -- Module      : Simplex.Messaging.ProtocolEncoding
 -- Copyright   : (c) simplex.chat
@@ -52,6 +52,7 @@ module Simplex.Messaging.Protocol
     SParty (..),
     PartyI (..),
     QueueIdsKeys (..),
+    ProtocolErrorType (..),
     ErrorType (..),
     CommandError (..),
     Transmission,
@@ -73,6 +74,9 @@ module Simplex.Messaging.Protocol
     SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    XFTPServer,
+    pattern XFTPServer,
+    XFTPServerWithAuth,
     ProtoServerWithAuth (..),
     BasicAuth (..),
     SrvLoc (..),
@@ -126,6 +130,10 @@ module Simplex.Messaging.Protocol
     -- * TCP transport functions
     tPut,
     tGet,
+    tParse,
+    tDecodeParseValidate,
+    tEncode,
+    tEncodeBatch,
 
     -- * exports for tests
     CommandTag (..),
@@ -160,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, (<$?>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
@@ -220,7 +228,7 @@ deriving instance Show Cmd
 type Transmission c = (CorrId, EntityId, c)
 
 -- | signed parsed transmission, with original raw bytes and parsing error.
-type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))
+type SignedTransmission e c = (Maybe C.ASignature, Signed, Transmission (Either e c))
 
 type Signed = ByteString
 
@@ -618,6 +626,15 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
 
 {-# COMPLETE NtfServer #-}
 
+type XFTPServer = ProtocolServer 'PXFTP
+
+pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP
+pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash
+
+{-# COMPLETE XFTPServer #-}
+
+type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP
+
 sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
 sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
 {-# INLINE sameSrvAddr' #-}
@@ -626,22 +643,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)
 
@@ -659,17 +679,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
@@ -695,6 +718,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,
@@ -726,8 +751,11 @@ instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance ProtocolTypeI p => FromJSON (ProtocolServer p) where
+  parseJSON = strParseJSON "ProtocolServer"
+
 newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 instance IsString BasicAuth where fromString = BasicAuth . B.pack
 
@@ -747,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
@@ -870,6 +898,8 @@ type MsgId = ByteString
 -- | SMP message body.
 type MsgBody = ByteString
 
+data ProtocolErrorType = PECmdSyntax | PECmdUnknown | PESession | PEBlock
+
 -- | Type for protocol errors.
 data ErrorType
   = -- | incorrect block format, encoding or signature size
@@ -940,16 +970,16 @@ transmissionP = do
       command <- A.takeByteString
       pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
 
-class (ProtocolEncoding msg, ProtocolEncoding (ProtoCommand msg), Show msg) => Protocol msg where
+class (ProtocolEncoding err msg, ProtocolEncoding err (ProtoCommand msg), Show err, Show msg) => Protocol err msg | msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
   protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
   protocolPing :: ProtoCommand msg
-  protocolError :: msg -> Maybe ErrorType
+  protocolError :: msg -> Maybe err
 
 type ProtoServer msg = ProtocolServer (ProtoType msg)
 
-instance Protocol BrokerMsg where
+instance Protocol ErrorType BrokerMsg where
   type ProtoCommand BrokerMsg = Cmd
   type ProtoType BrokerMsg = 'PSMP
   protocolClientHandshake = smpClientHandshake
@@ -958,13 +988,14 @@ instance Protocol BrokerMsg where
     ERR e -> Just e
     _ -> Nothing
 
-class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
+class ProtocolMsgTag (Tag msg) => ProtocolEncoding err msg | msg -> err where
   type Tag msg
   encodeProtocol :: Version -> msg -> ByteString
   protocolP :: Version -> Tag msg -> Parser msg
-  checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
+  fromProtocolError :: ProtocolErrorType -> err
+  checkCredentials :: SignedRawTransmission -> msg -> Either err msg
 
-instance PartyI p => ProtocolEncoding (Command p) where
+instance PartyI p => ProtocolEncoding ErrorType (Command p) where
   type Tag (Command p) = CommandTag p
   encodeProtocol v = \case
     NEW rKey dhKey auth_ -> case auth_ of
@@ -995,6 +1026,9 @@ instance PartyI p => ProtocolEncoding (Command p) where
 
   protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)
 
+  fromProtocolError = fromProtocolError @ErrorType @BrokerMsg
+  {-# INLINE fromProtocolError #-}
+
   checkCredentials (sig, _, queueId, _) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
     NEW {}
@@ -1014,7 +1048,7 @@ instance PartyI p => ProtocolEncoding (Command p) where
       | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
-instance ProtocolEncoding Cmd where
+instance ProtocolEncoding ErrorType Cmd where
   type Tag Cmd = CmdTag
   encodeProtocol v (Cmd _ c) = encodeProtocol v c
 
@@ -1044,9 +1078,12 @@ instance ProtocolEncoding Cmd where
         PING_ -> pure PING
     CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
 
+  fromProtocolError = fromProtocolError @ErrorType @BrokerMsg
+  {-# INLINE fromProtocolError #-}
+
   checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
 
-instance ProtocolEncoding BrokerMsg where
+instance ProtocolEncoding ErrorType BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
   encodeProtocol v = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
@@ -1081,6 +1118,13 @@ instance ProtocolEncoding BrokerMsg where
     ERR_ -> ERR <$> _smpP
     PONG_ -> pure PONG
 
+  fromProtocolError = \case
+    PECmdSyntax -> CMD SYNTAX
+    PECmdUnknown -> CMD UNKNOWN
+    PESession -> SESSION
+    PEBlock -> BLOCK
+  {-# INLINE fromProtocolError #-}
+
   checkCredentials (_, _, queueId, _) cmd = case cmd of
     -- IDS response should not have queue ID
     IDS _ -> Right cmd
@@ -1099,12 +1143,12 @@ _smpP :: Encoding a => Parser a
 _smpP = A.space *> smpP
 
 -- | Parse SMP protocol commands and broker messages
-parseProtocol :: ProtocolEncoding msg => Version -> ByteString -> Either ErrorType msg
+parseProtocol :: forall err msg. ProtocolEncoding err msg => Version -> ByteString -> Either err msg
 parseProtocol v s =
   let (tag, params) = B.break (== ' ') s
    in case decodeTag tag of
-        Just cmd -> parse (protocolP v cmd) (CMD SYNTAX) params
-        Nothing -> Left $ CMD UNKNOWN
+        Just cmd -> parse (protocolP v cmd) (fromProtocolError @err @msg $ PECmdSyntax) params
+        Nothing -> Left $ fromProtocolError @err @msg $ PECmdUnknown
 
 checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
 checkParty c = case testEquality (sParty @p) (sParty @p') of
@@ -1112,9 +1156,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
@@ -1169,7 +1211,7 @@ tPut th trs
     tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO [Either TransportError ()]
     tPutBatch rs ts = do
       let (n, s, ts_) = encodeBatch 0 "" ts
-      r <- if n == 0 then largeMsg else replicate n <$> tPutLog (lenEncode n `B.cons` s)
+      r <- if n == 0 then largeMsg else replicate n <$> tPutLog (tEncodeBatch n s)
       let rs' = rs <> r
       case ts_ of
         Just ts' -> tPutBatch rs' ts'
@@ -1192,41 +1234,49 @@ tPut th trs
               else case L.nonEmpty ts_ of
                 Just ts' -> encodeBatch n' s' ts'
                 _ -> (n', s', Nothing)
-    tEncode (sig, tr) = smpEncode (C.signatureBytes sig) <> tr
 
-encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
+tEncode :: (Maybe C.ASignature, ByteString) -> ByteString
+tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t
+
+tEncodeBatch :: Int -> ByteString -> ByteString
+tEncodeBatch n s = lenEncode n `B.cons` s
+
+encodeTransmission :: ProtocolEncoding e c => Version -> ByteString -> Transmission c -> ByteString
 encodeTransmission v sessionId (CorrId corrId, queueId, command) =
   smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
 
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
 tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
-tGetParse th
-  | batch th = either ((:| []) . Left) id <$> runExceptT getBatch
-  | otherwise = (:| []) . (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
+tGetParse th = eitherList (tParse $ batch th) <$> tGetBlock th
+
+tParse :: Bool -> ByteString -> NonEmpty (Either TransportError RawTransmission)
+tParse batch s
+  | batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
+  | otherwise = [tParse1 s]
   where
-    getBatch :: ExceptT TransportError IO (NonEmpty (Either TransportError RawTransmission))
-    getBatch = do
-      s <- ExceptT $ tGetBlock th
-      ts <- liftEither $ parse smpP TEBadBlock s
-      pure $ L.map (\(Large t) -> parse transmissionP TEBadBlock t) ts
+    tParse1 = parse transmissionP TEBadBlock
+    ts = parse smpP TEBadBlock s
+
+eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
+eitherList = either (\e -> [Left e])
 
 -- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (NonEmpty (SignedTransmission cmd))
-tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM decodeParseValidate
+tGet :: forall err cmd c. (ProtocolEncoding err cmd, Transport c) => THandle c -> IO (NonEmpty (SignedTransmission err cmd))
+tGet th@THandle {sessionId, thVersion = v} = L.map (tDecodeParseValidate sessionId v) <$> tGetParse th
+
+tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => SessionId -> Version -> Either TransportError RawTransmission -> SignedTransmission err cmd
+tDecodeParseValidate sessionId v = \case
+  Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
+    | sessId == sessionId ->
+      let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
+       in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
+    | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession))
+  Left _ -> tError ""
   where
-    decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
-    decodeParseValidate = \case
-      Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
-        | sessId == sessionId ->
-          let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
-           in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
-        | otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))
-      Left _ -> tError ""
+    tError :: ByteString -> SignedTransmission err cmd
+    tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock))
 
-    tError :: ByteString -> m (SignedTransmission cmd)
-    tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK))
-
-    tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
-    tParseValidate signed t@(sig, corrId, entityId, command) = do
-      let cmd = parseProtocol v command >>= checkCredentials t
-      pure (sig, signed, (CorrId corrId, entityId, cmd))
+    tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd
+    tParseValidate signed t@(sig, corrId, entityId, command) =
+      let cmd = parseProtocol @err @cmd v command >>= checkCredentials t
+       in (sig, signed, (CorrId corrId, entityId, cmd))

src/Simplex/Messaging/Server.hs

@@ -260,13 +260,13 @@ cancelSub sub =
 
 receive :: Transport c => THandle c -> Client -> M ()
 receive th Client {rcvQ, sndQ, activeAt} = forever $ do
-  ts <- L.toList <$> tGet th
+  ts <- L.toList <$> liftIO (tGet th)
   atomically . writeTVar activeAt =<< liftIO getSystemTime
   as <- partitionEithers <$> mapM cmdAction ts
   write sndQ $ fst as
   write rcvQ $ snd as
   where
-    cmdAction :: SignedTransmission Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
+    cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
     cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
       case cmdOrError of
         Left e -> pure $ Left (corrId, queueId, ERR e)
@@ -300,7 +300,7 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
 data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 
 verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
-verifyTransmission sig_ signed queueId cmd = do
+verifyTransmission sig_ signed queueId cmd =
   case cmd of
     Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
@@ -311,7 +311,7 @@ verifyTransmission sig_ signed queueId cmd = do
     verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
     verifyCmd party f = do
       st <- asks queueStore
-      q_ <- atomically (getQueue st party queueId)
+      q_ <- atomically $ getQueue st party queueId
       pure $ case q_ of
         Right q -> Just q `verified` f q
         _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed

src/Simplex/Messaging/Server/CLI.hs

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

src/Simplex/Messaging/Server/Main.hs

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

src/Simplex/Messaging/Server/StoreLog.hs

@@ -38,7 +38,7 @@ import qualified Data.Map.Strict as M
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
-import Simplex.Messaging.Transport (trimCR)
+import Simplex.Messaging.Transport.Buffer (trimCR)
 import System.Directory (doesFileExist)
 import System.IO
 

src/Simplex/Messaging/Transport.hs

@@ -56,9 +56,6 @@ module Simplex.Messaging.Transport
     transportErrorP,
     sendHandshake,
     getHandshake,
-
-    -- * Trim trailing CR
-    trimCR,
   )
 where
 
@@ -86,6 +83,7 @@ import qualified Paths_simplexmq as SMQ
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
+import Simplex.Messaging.Transport.Buffer
 import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
@@ -152,8 +150,7 @@ data TLS = TLS
   { tlsContext :: T.Context,
     tlsPeer :: TransportPeer,
     tlsUniq :: ByteString,
-    buffer :: TVar ByteString,
-    getLock :: TMVar ()
+    tlsBuffer :: TBuffer
   }
 
 connectTLS :: T.TLSParams p => Maybe HostName -> Bool -> p -> Socket -> IO T.Context
@@ -169,9 +166,8 @@ getTLS :: TransportPeer -> T.Context -> IO TLS
 getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS
   where
     newTLS tlsUniq = do
-      buffer <- newTVarIO ""
-      getLock <- newTMVarIO ()
-      pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, buffer, getLock}
+      tlsBuffer <- atomically newTBuffer
+      pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, tlsBuffer}
 
 withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
 withTlsUnique peer cxt f =
@@ -208,53 +204,22 @@ 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, buffer, getLock} n =
-    E.bracket_
-      (atomically $ takeTMVar getLock)
-      (atomically $ putTMVar getLock ())
-      $ do
-        b <- readChunks =<< readTVarIO buffer
-        let (s, b') = B.splitAt n b
-        atomically $ writeTVar buffer $! b'
-        pure s
-    where
-      readChunks :: ByteString -> IO ByteString
-      readChunks b
-        | B.length b >= n = pure b
-        | otherwise =
-          T.recvData tlsContext >>= \case
-            -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-            "" -> ioe_EOF
-            s -> readChunks $ b <> s
+  cGet TLS {tlsContext, tlsBuffer} n = getBuffered tlsBuffer n (T.recvData tlsContext)
 
   cPut :: TLS -> ByteString -> IO ()
   cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
 
   getLn :: TLS -> IO ByteString
-  getLn TLS {tlsContext, buffer, getLock} = do
-    E.bracket_
-      (atomically $ takeTMVar getLock)
-      (atomically $ putTMVar getLock ())
-      $ do
-        b <- readChunks =<< readTVarIO buffer
-        let (s, b') = B.break (== '\n') b
-        atomically $ writeTVar buffer $! B.drop 1 b' -- drop '\n' we made a break at
-        pure $ trimCR s
+  getLn TLS {tlsContext, tlsBuffer} = do
+    getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catch` handleEOF
     where
-      readChunks :: ByteString -> IO ByteString
-      readChunks b
-        | B.elem '\n' b = pure b
-        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
       handleEOF = \case
         T.Error_EOF -> E.throwIO TEBadBlock
         e -> E.throwIO e
 
--- | Trim trailing CR from ByteString.
-trimCR :: ByteString -> ByteString
-trimCR "" = ""
-trimCR s = if B.last s == '\r' then B.init s else s
-
 -- * SMP transport
 
 -- | The handle for SMP encrypted transport connection over Transport .
@@ -337,7 +302,7 @@ transportErrorP =
   "BLOCK" $> TEBadBlock
     <|> "LARGE_MSG" $> TELargeMsg
     <|> "SESSION" $> TEBadSession
-    <|> TEHandshake <$> parseRead1
+    <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
 
 -- | Serialize SMP encrypted transport error.
 serializeTransportError :: TransportError -> ByteString
@@ -345,7 +310,7 @@ serializeTransportError = \case
   TEBadBlock -> "BLOCK"
   TELargeMsg -> "LARGE_MSG"
   TEBadSession -> "SESSION"
-  TEHandshake e -> bshow e
+  TEHandshake e -> "HANDSHAKE " <> bshow e
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
@@ -355,10 +320,11 @@ tPutBlock THandle {connection = c, blockSize} block =
 
 -- | Receive block from SMP transport.
 tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, blockSize} =
-  cGet c blockSize >>= \case
-    "" -> ioe_EOF
-    msg -> pure . first (const TELargeMsg) $ C.unPad msg
+tGetBlock THandle {connection = c, blockSize} = do
+  msg <- cGet c blockSize
+  if B.length msg == blockSize
+    then pure . first (const TELargeMsg) $ C.unPad msg
+    else ioe_EOF
 
 -- | Server SMP transport handshake.
 --

src/Simplex/Messaging/Transport/Buffer.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Transport.Buffer where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+
+data TBuffer = TBuffer
+  { buffer :: TVar ByteString,
+    getLock :: TMVar ()
+  }
+
+newTBuffer :: STM TBuffer
+newTBuffer = do
+  buffer <- newTVar ""
+  getLock <- newTMVar ()
+  pure TBuffer {buffer, getLock}
+
+withBufferLock :: TBuffer -> IO a -> IO a
+withBufferLock TBuffer {getLock} =
+  E.bracket_
+    (atomically $ takeTMVar getLock)
+    (atomically $ putTMVar getLock ())
+
+getBuffered :: TBuffer -> Int -> IO ByteString -> IO ByteString
+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
+    readChunks b
+      | B.length b >= n = pure b
+      | otherwise =
+        getChunk >>= \case
+          "" -> pure b
+          s -> readChunks $ b <> s
+
+-- This function is only used in test and needs to be improved before it can be used in production,
+-- it will never complete if TLS connection is closed before there is newline.
+getLnBuffered :: TBuffer -> IO ByteString -> IO ByteString
+getLnBuffered tb@TBuffer {buffer} getChunk = withBufferLock tb $ do
+  b <- readChunks =<< readTVarIO buffer
+  let (s, b') = B.break (== '\n') b
+  atomically $ writeTVar buffer $! B.drop 1 b' -- drop '\n' we made a break at
+  pure $ trimCR s
+  where
+    readChunks :: ByteString -> IO ByteString
+    readChunks b
+      | B.elem '\n' b = pure b
+      | otherwise = readChunks . (b <>) =<< getChunk
+
+-- | Trim trailing CR from ByteString.
+trimCR :: ByteString -> ByteString
+trimCR "" = ""
+trimCR s = if B.last s == '\r' then B.init s else s

src/Simplex/Messaging/Transport/Client.hs

@@ -26,6 +26,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Char (isAsciiLower, isDigit)
 import Data.Default (def)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
@@ -70,11 +71,14 @@ instance StrEncoding TransportHost where
   strP =
     A.choice
       [ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
-        THOnionHost <$> ((<>) <$> A.takeTill (== '.') <*> A.string ".onion"),
-        THDomainName . B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
+        THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
+        THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
       ]
     where
-      ipNum = A.decimal <* A.char '.'
+      ipNum = validIP <$?> (A.decimal <* A.char '.')
+      validIP :: Int -> Either String Word8
+      validIP n = if 0 <= n && n <= 255 then Right $ fromIntegral n else Left "invalid IP address"
+      notOnion s = if ".onion" `B.isSuffixOf` s then Left "invalid onion host" else Right s
 
 instance ToJSON TransportHost where
   toEncoding = strToJEncoding

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -1,20 +1,32 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 module Simplex.Messaging.Transport.HTTP2 where
 
+import Control.Concurrent.STM
 import qualified Control.Exception as E
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Data.Default (def)
+import Data.Maybe (fromMaybe)
 import Foreign (mallocBytes)
 import Network.HPACK (BufferSize)
 import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
+import qualified Network.HTTP2.Client as HC
+import qualified Network.HTTP2.Server as HS
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
-import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
+import Simplex.Messaging.Transport (SessionId, TLS (tlsUniq), Transport (cGet, cPut))
+import Simplex.Messaging.Transport.Buffer
 import qualified System.TimeManager as TI
 
-withTlsConfig :: TLS -> BufferSize -> (Config -> IO ()) -> IO ()
-withTlsConfig c sz = E.bracket (allocTlsConfig c sz) freeSimpleConfig
+defaultHTTP2BufferSize :: BufferSize
+defaultHTTP2BufferSize = 32768
 
-allocTlsConfig :: TLS -> BufferSize -> IO Config
-allocTlsConfig c sz = do
+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
+allocHTTP2Config c sz = do
   buf <- mallocBytes sz
   tm <- TI.initialize $ 30 * 1000000
   pure
@@ -34,3 +46,36 @@ http2TLSParams =
       T.supportedCiphers = TE.ciphersuite_strong_det,
       T.supportedSecureRenegotiation = False
     }
+
+data HTTP2Body = HTTP2Body
+  { bodyHead :: ByteString,
+    bodySize :: Int,
+    bodyPart :: Maybe (Int -> IO ByteString),
+    bodyBuffer :: TBuffer
+  }
+
+class HTTP2BodyChunk a where
+  getBodyChunk :: a -> IO ByteString
+  getBodySize :: a -> Maybe Int
+
+instance HTTP2BodyChunk HC.Response where
+  getBodyChunk = HC.getResponseBodyChunk
+  {-# INLINE getBodyChunk #-}
+  getBodySize = HC.responseBodySize
+  {-# INLINE getBodySize #-}
+
+instance HTTP2BodyChunk HS.Request where
+  getBodyChunk = HS.getRequestBodyChunk
+  {-# INLINE getBodyChunk #-}
+  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 $ getBodySize r
+      -- TODO check bodySize once it is set
+      bodyPart = if B.length bodyHead == n then Just getPart else Nothing
+  pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer}

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -6,28 +7,39 @@
 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 qualified Data.ByteString.Char8 as B
-import Data.Maybe (isNothing)
+import Data.Functor (($>))
+import Data.Time (UTCTime, getCurrentTime)
 import qualified Data.X509.CertificateStore as XS
-import Network.HPACK (HeaderTable)
+import Network.HPACK (BufferSize)
 import Network.HTTP2.Client (ClientConfig (..), Request, Response)
 import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Transport (SessionId)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
-import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
+import Simplex.Messaging.Transport.HTTP2
 import UnliftIO.STM
 import UnliftIO.Timeout
 
 data HTTP2Client = HTTP2Client
-  { action :: Maybe (Async ()),
-    connected :: TVar Bool,
-    host :: HostName,
+  { 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,
     reqQ :: TBQueue (Request, TMVar HTTP2Response)
@@ -35,15 +47,15 @@ data HTTP2Client = HTTP2Client
 
 data HTTP2Response = HTTP2Response
   { response :: Response,
-    respBody :: ByteString,
-    respTrailers :: Maybe HeaderTable
+    respBody :: HTTP2Body
   }
 
 data HTTP2ClientConfig = HTTP2ClientConfig
   { qSize :: Natural,
     connTimeout :: Int,
     transportConfig :: TransportClientConfig,
-    caStoreFile :: FilePath,
+    bufferSize :: BufferSize,
+    bodyHeadSize :: Int,
     suportedTLSParams :: T.Supported
   }
   deriving (Show)
@@ -54,73 +66,89 @@ defaultHTTP2ClientConfig =
     { qSize = 64,
       connTimeout = 10000000,
       transportConfig = TransportClientConfig Nothing Nothing True,
-      caStoreFile = "/etc/ssl/cert.pem",
+      bufferSize = defaultHTTP2BufferSize,
+      bodyHeadSize = 16384,
       suportedTLSParams = http2TLSParams
     }
 
-data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | HCIOError IOException
+data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOException
   deriving (Show)
 
-getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout, caStoreFile, suportedTLSParams} disconnected =
+getHTTP2Client :: HostName -> ServiceName -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+getHTTP2Client host port = getVerifiedHTTP2Client Nothing (THDomainName host) port Nothing
+
+getVerifiedHTTP2Client :: Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2ClientConfig {transportConfig, bufferSize, bodyHeadSize, connTimeout, suportedTLSParams} disconnected =
   (atomically mkHTTPS2Client >>= runClient)
     `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
   where
-    mkHTTPS2Client :: STM HTTP2Client
+    mkHTTPS2Client :: STM HClient
     mkHTTPS2Client = do
       connected <- newTVar False
       reqQ <- newTBQueue $ qSize config
-      pure HTTP2Client {action = Nothing, connected, host, port, config, reqQ}
+      pure HClient {connected, disconnected, host, port, config, reqQ}
 
-    runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
+    runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
     runClient c = do
       cVar <- newEmptyTMVarIO
-      caStore <- XS.readCertificateStore caStoreFile
-      when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
       action <-
         async $
-          runHTTP2Client suportedTLSParams caStore transportConfig host port (client c cVar)
+          runHTTP2Client suportedTLSParams caStore transportConfig bufferSize proxyUsername host port keyHash (client c cVar)
             `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
-      conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
-      pure $ case conn_ of
-        Just (Right ()) -> Right c {action = Just action}
+      c_ <- connTimeout `timeout` atomically (takeTMVar cVar)
+      pure $ case c_ of
+        Just (Right c') -> Right c' {action = Just action}
         Just (Left e) -> Left e
-        Nothing -> Left HCNetworkError1
+        Nothing -> Left HCNetworkError
 
-    client :: HTTP2Client -> TMVar (Either HTTP2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    client c cVar sendReq = do
+    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, sendReq, sessionId, sessionTs}
       atomically $ do
         writeTVar (connected c) True
-        putTMVar cVar $ Right ()
-      process c sendReq `E.finally` disconnected
+        putTMVar cVar (Right c')
+      process c' sendReq `E.finally` disconnected
 
-    process :: HTTP2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    process HTTP2Client {reqQ} sendReq = forever $ do
+    process :: HTTP2Client -> H.Client HTTP2Response
+    process HTTP2Client {client_ = HClient {reqQ}} sendReq = forever $ do
       (req, respVar) <- atomically $ readTBQueue reqQ
       sendReq req $ \r -> do
-        let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers}
-        respBody <- getResponseBody r ""
-        respTrailers <- H.getResponseTrailers r
-        writeResp respBody respTrailers
-
-    getResponseBody :: Response -> ByteString -> IO ByteString
-    getResponseBody r s =
-      H.getResponseBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getResponseBody r $ s <> chunk
+        respBody <- getHTTP2Body r bodyHeadSize
+        let resp = HTTP2Response {response = r, respBody}
+        atomically $ putTMVar respVar resp
+        pure resp
 
 -- | Disconnects client from the server and terminates client threads.
 closeHTTP2Client :: HTTP2Client -> IO ()
 closeHTTP2Client = mapM_ uninterruptibleCancel . action
 
-sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
-sendRequest HTTP2Client {reqQ, config} req = do
+sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
+sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req reqTimeout_ = do
   resp <- newEmptyTMVarIO
   atomically $ writeTBQueue reqQ (req, resp)
-  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
+  let reqTimeout = http2RequestTimeout config reqTimeout_
+  maybe (Left HCResponseTimeout) Right <$> (reqTimeout `timeout` atomically (takeTMVar resp))
 
-runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> HostName -> ServiceName -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
-runHTTP2Client tlsParams caStore tcConfig host port client =
-  runTLSTransportClient tlsParams caStore tcConfig Nothing (THDomainName host) port Nothing $ \c ->
-    withTlsConfig c 16384 (`run` client)
+-- | this function should not be used until HTTP2 is thread safe, use sendRequest
+sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
+sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req reqTimeout_ = do
+  let reqTimeout = http2RequestTimeout config reqTimeout_
+  reqTimeout `timeout` try (sendReq req process) >>= \case
+    Just (Right r) -> pure $ Right r
+    Just (Left e) -> disconnected $> Left (HCIOError e)
+    Nothing -> pure $ Left HCNetworkError
   where
-    run = H.run $ ClientConfig "https" (B.pack host) 20
+    process r = do
+      respBody <- getHTTP2Body r $ bodyHeadSize config
+      pure HTTP2Response {response = r, respBody}
+
+http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
+http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
+
+runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client a) -> IO a
+runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash client =
+  runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash $ withHTTP2 bufferSize run
+  where
+    run :: H.Config -> SessionId -> IO a
+    run cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg . client

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

@@ -6,22 +6,23 @@ module Simplex.Messaging.Transport.HTTP2.Server where
 import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
 import Control.Concurrent.STM
 import Control.Monad
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Network.HPACK (HeaderTable)
-import Network.HTTP2.Server (Aux, PushPromise, Request, Response)
+import Network.HPACK (BufferSize)
+import Network.HTTP2.Server (Request, Response)
 import qualified Network.HTTP2.Server as H
 import Network.Socket
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.HTTP2 (withTlsConfig)
+import Simplex.Messaging.Transport (SessionId)
+import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
 
-type HTTP2ServerFunc = (Request -> (Response -> IO ()) -> IO ())
+type HTTP2ServerFunc = SessionId -> Request -> (Response -> IO ()) -> IO ()
 
 data HTTP2ServerConfig = HTTP2ServerConfig
   { qSize :: Natural,
     http2Port :: ServiceName,
+    bufferSize :: BufferSize,
+    bodyHeadSize :: Int,
     serverSupported :: T.Supported,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -31,9 +32,9 @@ data HTTP2ServerConfig = HTTP2ServerConfig
   deriving (Show)
 
 data HTTP2Request = HTTP2Request
-  { request :: Request,
-    reqBody :: ByteString,
-    reqTrailers :: Maybe HeaderTable,
+  { sessionId :: SessionId,
+    request :: Request,
+    reqBody :: HTTP2Body,
     sendResponse :: Response -> IO ()
   }
 
@@ -42,30 +43,24 @@ data HTTP2Server = HTTP2Server
     reqQ :: TBQueue HTTP2Request
   }
 
+-- This server is for testing only, it processes all requests in a single queue.
 getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile, logTLSErrors} = do
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, logTLSErrors} = do
   tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port tlsServerParams logTLSErrors $ \r sendResponse -> do
-      reqBody <- getRequestBody r ""
-      reqTrailers <- H.getRequestTrailers r
-      atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
+    runHTTP2Server started http2Port bufferSize tlsServerParams logTLSErrors $ \sessionId r sendResponse -> do
+      reqBody <- getHTTP2Body r bodyHeadSize
+      atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
   pure HTTP2Server {action, reqQ}
-  where
-    getRequestBody :: Request -> ByteString -> IO ByteString
-    getRequestBody r s =
-      H.getRequestBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getRequestBody r $ s <> chunk
 
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port serverParams logTLSErrors http2Server =
-  runTransportServer started port serverParams logTLSErrors $ \c -> withTlsConfig c 16384 (`H.run` server)
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port bufferSize serverParams logTLSErrors http2Server =
+  runTransportServer started port serverParams logTLSErrors $ withHTTP2 bufferSize run
   where
-    server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
-    server req _aux sendResp = http2Server req (`sendResp` [])
+    run cfg sessId = H.run cfg $ \req _aux sendResp -> http2Server sessId req (`sendResp` [])

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -19,9 +19,9 @@ import Simplex.Messaging.Transport
     TransportPeer (..),
     closeTLS,
     smpBlockSize,
-    trimCR,
     withTlsUnique,
   )
+import Simplex.Messaging.Transport.Buffer (trimCR)
 
 data WS = WS
   { wsPeer :: TransportPeer,

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

tests/AgentTests/FunctionalAPITests.hs

@@ -25,6 +25,7 @@ module AgentTests.FunctionalAPITests
   )
 where
 
+import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams)
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad
 import Control.Monad.Except (ExceptT, runExceptT, throwError)
@@ -45,8 +46,9 @@ 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
-import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..))
+import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), supportedSMPClientVRange)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
@@ -85,7 +87,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
@@ -96,8 +98,10 @@ runRight action =
 
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
-  describe "Establishing duplex connection" $
+  describe "Establishing duplex connection" $ do
     testMatrix2 t runAgentClientTest
+    it "should connect when server with multiple identities is stored" $
+      withSmpServer t testServerMultipleIdentities
   describe "Establishing duplex connection v2, different Ratchet versions" $
     testRatchetMatrix2 t runAgentClientTest
   describe "Establish duplex connection via contact address" $
@@ -1010,6 +1014,40 @@ testTwoUsers = do
     hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
     hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
 
+testServerMultipleIdentities :: HasCallStack => IO ()
+testServerMultipleIdentities = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  runRight_ $ do
+    (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    allowConnection alice bobId confId "alice's connInfo"
+    get alice ##> ("", bobId, CON)
+    get bob ##> ("", aliceId, INFO "alice's connInfo")
+    get bob ##> ("", aliceId, CON)
+    exchangeGreetings alice bobId bob aliceId
+    -- this saves queue with second server identity
+    Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo"
+    disconnectAgentClient bob
+    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+    subscribeConnection bob' aliceId
+    exchangeGreetingsMsgId 6 alice bobId bob' aliceId
+  where
+    secondIdentityCReq :: ConnectionRequestUri 'CMInvitation
+    secondIdentityCReq =
+      CRInvitationUri
+        connReqData
+          { crSmpQueues =
+              [ SMPQueueUri
+                  supportedSMPClientVRange
+                  queueAddr
+                    { smpServer = SMPServer "localhost" "5001" (C.KeyHash "\215m\248\251")
+                    }
+              ]
+          }
+        testE2ERatchetParams
+
 exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings = exchangeGreetingsMsgId 4
 

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
 

tests/AgentTests/SQLiteTests.hs

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

tests/CLITests.hs

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

tests/CoreTests/CryptoTests.hs

@@ -3,11 +3,18 @@
 
 module CoreTests.CryptoTests (cryptoTests) where
 
+import Control.Monad.Except
+import Crypto.Random (getRandomBytes)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (isRight)
+import Data.Int (Int64)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LE
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
@@ -36,24 +43,69 @@ cryptoTests = do
     it "unpad should fail on shorter string" $ do
       C.unPad "\000\003abc" `shouldBe` Right "abc"
       C.unPad "\000\003ab" `shouldBe` Left C.CryptoInvalidMsgError
+  modifyMaxSuccess (const 10000) . describe "lazy padding / unpadding" $ do
+    it "should pad / unpad lazy bytestrings" . property $ \(s, paddedLen) ->
+      let b = LE.encodeUtf8 $ LT.pack s
+          len = LB.length b
+          padded = LC.pad b len paddedLen
+       in if len <= paddedLen - 8
+            then (padded >>= LC.unPad) == Right b
+            else padded == Left C.CryptoLargeMsgError
+    it "pad should support large string" $ do
+      LC.pad "abc" 3 11 `shouldBe` Right "\000\000\000\000\000\000\000\003abc"
+      LC.pad "abc" 3 10 `shouldBe` Left C.CryptoLargeMsgError
+      let s = LB.replicate 100000 'a'
+      (LC.pad s 100000 100100 >>= LC.unPad) `shouldBe` Right s
+      (LC.pad s 100000 100008 >>= LC.unPad) `shouldBe` Right s
+      (LC.pad s 100000 100007 >>= LC.unPad) `shouldBe` Left C.CryptoLargeMsgError
+    it "pad should truncate string if a shorter length is passed and unpad incorrectly when longer length is passed" $ do
+      let s = LB.replicate 10000 'a'
+      (LC.pad s 9000 10100 >>= LC.unPad) `shouldBe` Right (LB.take 9000 s)
+      (LC.pad s 11000 11100 >>= LC.unPad) `shouldBe` Right (s <> LB.replicate 92 '#') -- 92 = pad size, it is not truncated in this case
+    it "unpad should fail on invalid string" $ do
+      LC.unPad "\000\000\000\000\000\000\000\000" `shouldBe` Right ""
+      LC.unPad "\000\000" `shouldBe` Left C.CryptoInvalidMsgError
+      LC.unPad "" `shouldBe` Left C.CryptoInvalidMsgError
+    it "unpad won't fail on shorter string" $ do
+      LC.unPad "\000\000\000\000\000\000\000\003abc" `shouldBe` Right "abc"
+      LC.unPad "\000\000\000\000\000\000\000\003ab" `shouldBe` Right "ab"
+    it "should pad / unpad file" testPadUnpadFile
   describe "Ed signatures" $ do
     describe "Ed25519" $ testSignature C.SEd25519
     describe "Ed448" $ testSignature C.SEd448
-  describe "DH X25519 + cryptobox" $
-    testDHCryptoBox
+  describe "DH X25519 + cryptobox" testDHCryptoBox
+  describe "secretbox" testSecretBox
+  describe "lazy secretbox" $ do
+    testLazySecretBox
+    testLazySecretBoxFile
+    testLazySecretBoxTailTag
+    testLazySecretBoxFileTailTag
+  describe "AES GCM" $ do
+    testAESGCM
   describe "X509 key encoding" $ do
     describe "Ed25519" $ testEncoding C.SEd25519
     describe "Ed448" $ testEncoding C.SEd448
     describe "X25519" $ testEncoding C.SX25519
     describe "X448" $ testEncoding C.SX448
 
+testPadUnpadFile :: IO ()
+testPadUnpadFile = do
+  let f = "tests/tmp/testpad"
+      paddedLen = 1024 * 1024
+      len = 1000000
+      s = LB.replicate len 'a'
+  Right s' <- pure $ LC.pad s len paddedLen
+  LB.writeFile (f <> ".padded") s'
+  Right s'' <- LC.unPad <$> LB.readFile (f <> ".padded")
+  s'' `shouldBe` s
+
 testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec
 testSignature alg = it "should sign / verify string" . ioProperty $ do
   (k, pk) <- C.generateSignatureKeyPair alg
   pure $ \s -> let b = encodeUtf8 $ T.pack s in C.verify k (C.sign pk b) b
 
 testDHCryptoBox :: Spec
-testDHCryptoBox = it "should encrypt / decrypt string" . ioProperty $ do
+testDHCryptoBox = it "should encrypt / decrypt string with asymmetric DH keys" . ioProperty $ do
   (sk, spk) <- C.generateKeyPair'
   (rk, rpk) <- C.generateKeyPair'
   nonce <- C.randomCbNonce
@@ -64,6 +116,81 @@ testDHCryptoBox = it "should encrypt / decrypt string" . ioProperty $ do
         plain = C.cbDecrypt (C.dh' sk rpk) nonce =<< cipher
      in isRight cipher && cipher /= plain && Right b == plain
 
+testSecretBox :: Spec
+testSecretBox = it "should encrypt / decrypt string with a random symmetric key" . ioProperty $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  pure $ \(s, pad) ->
+    let b = encodeUtf8 $ T.pack s
+        pad' = min (abs pad) 100000
+        paddedLen = B.length b + pad' + 2
+        cipher = C.sbEncrypt k nonce b paddedLen
+        plain = C.sbDecrypt k nonce =<< cipher
+     in isRight cipher && cipher /= plain && Right b == plain
+
+testLazySecretBox :: Spec
+testLazySecretBox = it "should lazily encrypt / decrypt string with a random symmetric key" . 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.sbEncrypt k nonce b len paddedLen
+        plain = LC.sbDecrypt k nonce =<< cipher
+     in isRight cipher && cipher /= plain && Right b == plain
+
+testLazySecretBoxFile :: Spec
+testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random symmetric key" $ 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.sbEncrypt k nonce s len paddedLen
+  LB.writeFile (f <> ".encrypted") s'
+  Right s'' <- LC.sbDecrypt k nonce <$> LB.readFile (f <> ".encrypted")
+  s'' `shouldBe` s
+
+testLazySecretBoxTailTag :: Spec
+testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a random symmetric key (tail tag)" . ioProperty $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  pure $ \(s, pad) ->
+    let b = LE.encodeUtf8 $ LT.pack s
+        len = LB.length b
+        pad' = min (abs pad) 100000
+        paddedLen = len + pad' + 8
+        cipher = LC.sbEncryptTailTag k nonce b len paddedLen
+        plain = LC.sbDecryptTailTag k nonce paddedLen =<< cipher
+     in isRight cipher && cipher /= (snd <$> plain) && Right (True, b) == plain
+
+testLazySecretBoxFileTailTag :: Spec
+testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a random symmetric key (tail tag)" $ do
+  k <- C.randomSbKey
+  nonce <- C.randomCbNonce
+  let f = "tests/tmp/testsecretbox"
+      paddedLen = 4 * 1024 * 1024
+      len = 4 * 1000 * 1000 :: Int64
+      s = LC.fastReplicate len 'a'
+  Right s' <- pure $ LC.sbEncryptTailTag k nonce s len paddedLen
+  LB.writeFile (f <> ".encrypted") s'
+  Right (auth, s'') <- LC.sbDecryptTailTag k nonce paddedLen <$> LB.readFile (f <> ".encrypted")
+  s'' `shouldBe` s
+  auth `shouldBe` True
+
+testAESGCM :: Spec
+testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do
+  k <- C.randomAesKey
+  iv <- C.randomGCMIV
+  s <- getRandomBytes 100
+  Right (tag, cipher) <- runExceptT $ C.encryptAESNoPad k iv s
+  Right plain <- runExceptT $ C.decryptAESNoPad k iv cipher tag
+  cipher `shouldNotBe` plain
+  s `shouldBe` plain
+
 testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec
 testEncoding alg = it "should encode / decode key" . ioProperty $ do
   (k, pk) <- C.generateKeyPair alg

tests/CoreTests/EncodingTests.hs

@@ -1,4 +1,7 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module CoreTests.EncodingTests where
 
@@ -10,7 +13,9 @@ import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime, utcToSystemTime)
 import Data.Time.ISO8601 (parseISO8601)
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
@@ -39,8 +44,36 @@ encodingTests = modifyMaxSuccess (const 1000) $ do
       testSystemTime t'
     it "parse(encode(SystemTime) should equal the same Int64" . property $
       \i -> parseAll smpP (smpEncode i) == Right (i :: Int64)
+  describe "Encoding transport hosts" $ do
+    describe "domain name hosts" $ do
+      it "should encode / decode domain name" $ THDomainName "smp.simplex.im" #==# "smp.simplex.im"
+      it "should not allow whitespace or punctuation" $ do
+        shouldNotParse @TransportHost "smp,simplex.im" "endOfInput"
+        shouldNotParse @TransportHost "smp:simplex.im" "endOfInput"
+        shouldNotParse @TransportHost "smp#simplex.im" "endOfInput"
+        shouldNotParse @TransportHost "smp simplex.im" "endOfInput"
+        shouldNotParse @TransportHost "smp\nsimplex.im" "endOfInput"
+    describe "onion hosts" $ do
+      it "should encode / decode onion host" $ THOnionHost "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion" #==# "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion"
+      it "should only allow latin letters and digits" $ do
+        shouldNotParse @TransportHost "beccx4yfxxbvyhqypaavemqurytl 6hozr47wfc7uuecacjqdvwpw2xid.onion" "endOfInput"
+        shouldNotParse @TransportHost "beccx4yfxxbvyhqypaavemqurytl\n6hozr47wfc7uuecacjqdvwpw2xid.onion" "endOfInput"
+        shouldNotParse @TransportHost "bèccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion" "Failed reading: empty"
+    describe "IP address hosts" $ do
+      it "should encode / decode IP address" $ THIPv4 (192, 168, 0, 1) #==# "192.168.0.1"
+      it "should be valid" $ do
+        THDomainName "192.168.1" #==# "192.168.1"
+        THDomainName "192.256.0.1" #==# "192.256.0.1"
+        THDomainName "192.168.0.-1" #==# "192.168.0.-1"
+        shouldNotParse @TransportHost "192.168.0.0.1" "endOfInput"
   where
     testSystemTime :: SystemTime -> Expectation
     testSystemTime t = do
       smpEncode t `shouldBe` smpEncode (systemSeconds t)
-      parseAll smpP (smpEncode t) `shouldBe` Right t {systemNanoseconds = 0}
+      smpDecode (smpEncode t) `shouldBe` Right t {systemNanoseconds = 0}
+    (#==#) :: (StrEncoding s, Eq s, Show s) => s -> ByteString -> Expectation
+    (#==#) x s = do
+      strEncode x `shouldBe` s
+      strDecode s `shouldBe` Right x
+    shouldNotParse :: forall s. (StrEncoding s, Eq s, Show s) => ByteString -> String -> Expectation
+    shouldNotParse s err = strDecode s `shouldBe` (Left err :: Either String s)

tests/CoreTests/ProtocolErrorTests.hs

@@ -6,7 +6,7 @@ module CoreTests.ProtocolErrorTests where
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
-import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
+import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Test.Hspec
@@ -17,12 +17,14 @@ protocolErrorTests :: Spec
 protocolErrorTests = modifyMaxSuccess (const 1000) $ do
   describe "errors parsing / serializing" $ do
     it "should parse SMP protocol errors" . property $ \(err :: AgentErrorType) ->
-      errServerHasSpaces err
+      errHasSpaces err
         || parseAll strP (strEncode err) == Right err
     it "should parse SMP agent errors" . property $ \(err :: AgentErrorType) ->
-      errServerHasSpaces err
+      errHasSpaces err
         || parseAll strP (strEncode err) == Right err
   where
-    errServerHasSpaces = \case
-      BROKER srv _ -> ' ' `B.elem` encodeUtf8 (T.pack srv)
+    errHasSpaces = \case
+      BROKER srv (RESPONSE e) -> hasSpaces srv || hasSpaces e
+      BROKER srv _ -> hasSpaces srv
       _ -> False
+    hasSpaces s = ' ' `B.elem` encodeUtf8 (T.pack s)

tests/FileDescriptionTests.hs

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

tests/NtfClient.hs

@@ -30,6 +30,7 @@ import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
+import SMPClient (serverBracket)
 import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
@@ -41,15 +42,13 @@ import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.HTTP2 (http2TLSParams)
-import Simplex.Messaging.Transport.HTTP2.Client
+import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Server
 import Test.Hspec
 import UnliftIO.Async
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
-import UnliftIO.Timeout (timeout)
 
 testHost :: NonEmpty TransportHost
 testHost = "localhost"
@@ -87,7 +86,7 @@ ntfServerCfg =
       apnsConfig =
         defaultAPNSPushClientConfig
           { apnsPort = apnsTestPort,
-            http2cfg = defaultHTTP2ClientConfig {caStoreFile = "tests/fixtures/ca.crt"}
+            caStoreFile = "tests/fixtures/ca.crt"
           },
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       storeLogFile = Nothing,
@@ -116,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
 
@@ -175,6 +161,8 @@ apnsMockServerConfig =
   HTTP2ServerConfig
     { qSize = 1,
       http2Port = apnsTestPort,
+      bufferSize = 16384,
+      bodyHeadSize = 16384,
       serverSupported = http2TLSParams,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
@@ -210,16 +198,16 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
   pure APNSMockServer {action, apnsQ, http2Server}
   where
     runAPNSMockServer apnsQ HTTP2Server {reqQ} = forever $ do
-      HTTP2Request {reqBody, sendResponse} <- atomically $ readTBQueue reqQ
+      HTTP2Request {reqBody = HTTP2Body {bodyHead}, sendResponse} <- atomically $ readTBQueue reqQ
       let sendApnsResponse = \case
             APNSRespOk -> sendResponse $ H.responseNoBody N.ok200 []
             APNSRespError status reason ->
               sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason}
-      case J.decodeStrict' reqBody of
+      case J.decodeStrict' bodyHead of
         Just notification ->
           atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
         _ -> do
-          putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show reqBody
+          putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show bodyHead
           sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
 
 closeAPNSMockServer :: APNSMockServer -> IO ()

tests/NtfServerTests.hs

@@ -64,16 +64,16 @@ ntfSyntaxTests (ATransport t) = do
       Expectation
     command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
 
-pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission NtfResponse
+pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse
 pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command))
 
-sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
+sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
 sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (sgn, t)
   tGet1 h
 
-signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
+signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
 signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (Just $ C.sign pk t, t)

tests/ServerTests.hs

@@ -63,7 +63,7 @@ serverTests t@(ATransport t') = do
     testMsgExpireOnInterval t'
     testMsgNOTExpireOnInterval t'
 
-pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission BrokerMsg
+pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg
 pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
 
 pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
@@ -72,13 +72,13 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
 pattern Msg :: MsgId -> MsgBody -> BrokerMsg
 pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
 
-sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
+sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
 sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (sgn, t)
   tGet1 h
 
-signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
+signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
 signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (Just $ C.sign pk t, t)
@@ -89,9 +89,9 @@ tPut1 h t = do
   [r] <- tPut h [t]
   pure r
 
-tGet1 :: (ProtocolEncoding cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission cmd)
+tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd)
 tGet1 h = do
-  [r] <- tGet h
+  [r] <- liftIO $ tGet h
   pure r
 
 (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
@@ -428,7 +428,7 @@ testSwitchSub (ATransport t) =
       Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3)
       (ok3, OK) #== "accepts ACK from the 2nd TCP connection"
 
-      1000 `timeout` tGet @BrokerMsg rh1 >>= \case
+      1000 `timeout` tGet @ErrorType @BrokerMsg rh1 >>= \case
         Nothing -> return ()
         Just _ -> error "nothing else is delivered to the 1st TCP connection"
 
@@ -869,14 +869,14 @@ testMessageNotifications (ATransport t) =
       Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
       (dec mId2 msg2, Right "hello again") #== "delivered from queue again"
       Resp "" _ (NMSG _ _) <- tGet1 nh2
-      1000 `timeout` tGet @BrokerMsg nh1 >>= \case
+      1000 `timeout` tGet @ErrorType @BrokerMsg nh1 >>= \case
         Nothing -> pure ()
         Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
       Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
       Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
       Resp "" _ (Msg mId3 msg3) <- tGet1 rh
       (dec mId3 msg3, Right "hello there") #== "delivered from queue again"
-      1000 `timeout` tGet @BrokerMsg nh2 >>= \case
+      1000 `timeout` tGet @ErrorType @BrokerMsg nh2 >>= \case
         Nothing -> pure ()
         Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
 
@@ -895,7 +895,7 @@ testMsgExpireOnSend t =
         testSMPClient @c $ \rh -> do
           Resp "3" _ (Msg mId msg) <- signSendRecv rh rKey ("3", rId, SUB)
           (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
-          1000 `timeout` tGet @BrokerMsg rh >>= \case
+          1000 `timeout` tGet @ErrorType @BrokerMsg rh >>= \case
             Nothing -> return ()
             Just _ -> error "nothing else should be delivered"
 
@@ -911,7 +911,7 @@ testMsgExpireOnInterval t =
         threadDelay 2500000
         testSMPClient @c $ \rh -> do
           Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, SUB)
-          1000 `timeout` tGet @BrokerMsg rh >>= \case
+          1000 `timeout` tGet @ErrorType @BrokerMsg rh >>= \case
             Nothing -> return ()
             Just _ -> error "nothing should be delivered"
 
@@ -929,7 +929,7 @@ testMsgNOTExpireOnInterval t =
         testSMPClient @c $ \rh -> do
           Resp "2" _ (Msg mId msg) <- signSendRecv rh rKey ("2", rId, SUB)
           (dec mId msg, Right "hello (should NOT expire)") #== "delivered"
-          1000 `timeout` tGet @BrokerMsg rh >>= \case
+          1000 `timeout` tGet @ErrorType @BrokerMsg rh >>= \case
             Nothing -> return ()
             Just _ -> error "nothing else should be delivered"
 

tests/Test.hs

@@ -8,6 +8,7 @@ import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
 import CoreTests.RetryIntervalTests
 import CoreTests.VersionRangeTests
+import FileDescriptionTests (fileDescriptionTests)
 import NtfServerTests (ntfServerTests)
 import ServerTests
 import Simplex.Messaging.Transport (TLS, Transport (..))
@@ -15,6 +16,8 @@ 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
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -39,4 +42,8 @@ main = do
         describe "SMP server via WebSockets" $ serverTests (transport @WS)
         describe "Notifications server" $ ntfServerTests (transport @TLS)
         describe "SMP client agent" $ agentTests (transport @TLS)
+        describe "XFTP" $ do
+          describe "XFTP server" xftpServerTests
+          describe "XFTP file description" fileDescriptionTests
+          describe "XFTP CLI" xftpCLITests
         describe "Server CLIs" cliTests

tests/XFTPCLI.hs

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

tests/XFTPClient.hs

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

tests/XFTPServerTests.hs

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

tests/fixtures/file_description.yaml

@@ -0,0 +1,23 @@
+chunkSize: 8mb
+digest: YWJj
+key: 00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=
+nonce: dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu
+party: recipient
+replicas:
+- chunks:
+  - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
+  - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
+  server: xftp://[email protected]
+- chunks:
+  - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
+  - 4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp:2mb
+  server: xftp://[email protected]
+- chunks:
+  - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  - 4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  server: xftp://[email protected]
+- chunks:
+  - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe
+  server: xftp://[email protected]
+size: 26mb