v5.0.0-beta.2

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

* hardcode default servers

* disable rand command

* hide rand command instead of removing

.github/workflows/build.yml

@@ -11,35 +11,53 @@ on:
 
 jobs:
   build:
-    runs-on: ubuntu-20.04
+    name: build-${{ matrix.os }}
+    runs-on: ${{ matrix.os }}
+    strategy:
+      fail-fast: false
+      matrix:
+        include:
+          - os: ubuntu-18.04
+          - os: ubuntu-20.04
     steps:
       - name: Clone project
         uses: actions/checkout@v2
 
-      - name: Setup Stack
+      - name: Setup Haskell
         uses: haskell/actions/setup@v1
         with:
           ghc-version: "8.10.7"
-          enable-stack: true
-          stack-version: "latest"
+          cabal-version: "latest"
 
       - name: Cache dependencies
         uses: actions/cache@v2
         with:
-          path: ~/.stack
-          key: ${{ hashFiles('stack.yaml') }}
+          path: |
+            ~/.cabal/store
+            dist-newstyle
+          key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
 
-      - name: Build & test
-        id: build_test
+      - name: Build
+        shell: bash
+        run: cabal build --enable-tests
+
+      - name: Test
+        if: matrix.os == 'ubuntu-18.04'
+        timeout-minutes: 30
+        shell: bash
+        run: cabal test --test-show-details=direct
+
+      - name: Prepare binaries
+        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
         shell: bash
         run: |
-          stack build --test --force-dirty
-          install_root=$(stack path --local-install-root)
-          mv ${install_root}/bin/smp-server smp-server-ubuntu-20_04-x86-64
-          mv ${install_root}/bin/ntf-server ntf-server-ubuntu-20_04-x86-64
+          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')
+        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
         id: build_changelog
         uses: mikepenz/release-changelog-builder-action@v1
         with:
@@ -50,19 +68,8 @@ jobs:
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
 
-      - name: Extract release candidate
-        if: startsWith(github.ref, 'refs/tags/v')
-        id: extract_release_candidate
-        shell: bash
-        run: |
-          if [[ ${GITHUB_REF} == *rc* ]]; then
-            echo "::set-output name=release_candidate::true"
-          else
-            echo "::set-output name=release_candidate::false"
-          fi
-
       - name: Create release
-        if: startsWith(github.ref, 'refs/tags/v')
+        if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
         uses: softprops/action-gh-release@v1
         with:
           body: |
@@ -70,11 +77,13 @@ jobs:
 
             Commits:
             ${{ steps.build_changelog.outputs.changelog }}
-          prerelease: ${{ steps.extract_release_candidate.outputs.release_candidate }}
+          prerelease: true
           files: |
             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 }}

.gitignore

@@ -4,3 +4,6 @@
 *.session.sql
 tests/tmp
 dist-newstyle/
+
+cabal.project.local
+cabal.project.local~

CHANGELOG.md

@@ -1,3 +1,121 @@
+# 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:
+
+- support multiple user profiles with transport session isolation.
+- support optional transport isolation per connection.
+- batch connection deletion
+- improve asynchronous connection deletion – it may now be completed after the client is restarted as well.
+- improve subscription logic to retry if initial attempt fails.
+- end SMP client connection after a number of failed PINGs (defalt is 3).
+
+# 4.3.0
+
+SMP server:
+
+- additional server usage statistics.
+
+SMP agent:
+
+- increase retry interval when sending messages after ERR QUOTA.
+
+# 4.2.0
+
+SMP agent and server:
+
+- reduce sender traffic in cases when queue quota is exceeded:
+  - server sends quota exceeded message to the recipient when sender receives ERR QUOTA.
+  - recipient sends QCONT message to the send once the queue is drained (via reply queue).
+  - sender retry delays are increased, reducing traffic, but sender instantly resumes delivery where QCONT is received.
+
+SMP server:
+
+- increase internal queue sizes.
+
+SMP agent:
+
+- deduplicate connection IDs in connect/disconnect responses.
+- unit tests for Crypto.hs.
+- fix connection switch to another queue: correctly set primary send queue.
+
+Notification server (v1.3.0):
+
+- check token status when sending verification notificaiton.
+
+# 4.1.0
+
+SMP agent and server:
+
+- option to toggle TLS handshake error logs (disabled by default).
+
+SMP agent:
+
+- include server address in BROKER error.
+- api to get hash of double ratchet associated data (for connection verification).
+- api to get agent statistics.
+
+# 4.0.0
+
+SMP server:
+
+- Basic authentication. The server address can now include an optional password that is required to create messaging queues, so the contacts who message you will not be able to receive messages via your server, unless you share with them the address with the password. It is recommended to enable basic authentication on all private servers by adding `create_password` parameter into AUTH section of server INI file (the previously deployed servers do not have this section, you need to add it).
+- Disable creating new queues completely with `new_queues: off` parameter in AUTH section of INI file - it can be used to simplify migrating the exising connections to another server.
+- Updated server CLI with changed defaults:
+  - interactive server initialization, use -y flag to initalize the server non-interactively.
+  - store log is now enabled by default, so messaging queues and messages are restored when the server is restarted (to restore undelivered messages the server needs to be stopped with SIGINT signal).
+  - a random password is now generated by default during the server initialization.
+
+SMP agent:
+
+- API to test SMP servers. It connects to the server, creates and deletes a messaging queue. The new SimpleX Chat client uses this API to allow you to test that you have the correct server address, with the valid certificate fingerprint and pasword, before enabling the new server.
+
+# 3.4.0
+
+SMP agent:
+
+- increase concurrency with connection-level locks
+- fix issues identified in security assessment (see the announcement: https://github.com/simplex-chat/simplex-chat/blob/stable/blog/20221108-simplex-chat-v4.2-security-audit-new-website.md)
+- manual connection queue rotation
+- optional client data in connection requests links
+
+SMP server:
+
+- specialize monad stack to improve performance
+- log slow commands
+
+# 3.3.0
+
+SMP server:
+
+- allow repeated KEY command with the same key (to avoid failures on retries)
+
+SMP agent:
+
+- enable/disable connection notifications
+- asynchronous commands that retry on network error
+- use SQLCipher
+
+# 3.2.0
+
+SMP agent:
+
+- Support multiple server hostnames (including onion hostnames) in server addresses.
+- Network configuration options.
+- Options to define rules to choose server hostname.
+
+# 3.1.0
+
+SMP server and agent:
+
+- SMP protocol v4: batching multiple server commands/responses in a transport block.
+
 # 3.0.0
 
 SMP server:

README.md

@@ -11,7 +11,7 @@ If you have a server deployed please deploy a new server to a new host and retir
 
 ## Message broker for unidirectional (simplex) queues
 
-SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
+SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](./protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](./protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
 
 SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.
 
@@ -27,7 +27,7 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
 
 ### SMP server
 
-[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
+[SMP server](./apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
 
 To initialize the server use `smp-server init -n <fqdn>` (or `smp-server init --ip <ip>` for IP based address) command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
 
@@ -39,7 +39,7 @@ Starting from version 2.3.0, when store log is enabled, the server would also en
 
 > **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
 
-SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
+SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
 
 #### Running SMP server on MacOS
 
@@ -62,7 +62,7 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP client library
 
-[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
+[SMP client](./src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
 
 - execute commands with a functional API.
 - receive messages and other notifications via STM queue.
@@ -70,13 +70,13 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP agent
 
-[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
+[SMP agent library](./src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
 
-Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
+Haskell type [ACommand](./src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
 
 See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
 
-[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
+[SMP agent executable](./apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](./protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
 
 ## Using SMP server and SMP agent
 
@@ -94,23 +94,107 @@ It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.
 
 You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
 
-- For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
+Notice that `smp-server` requires `openssl` as run-time dependency (it is used to generate server certificates during initialization). Install it with your packet manager:
 
-  If you're using other Linux distribution and the binary is incompatible with it, you can build from source using [Haskell stack](https://docs.haskellstack.org/en/stable/README/):
+```sh
+# For Ubuntu
+apt update && apt install openssl
+```
 
-  ```shell
-  curl -sSL https://get.haskellstack.org/ | sh
-  ...
-  stack install
-  ```
+### Install binaries
+
+#### Using Docker
+
+On Linux, you can deploy smp server using Docker. This will download image from [Docker Hub](https://hub.docker.com/r/simplexchat/simplexmq).
+
+1. Create `config` and `logs` directories:
+
+   ```sh
+   mkdir -p ~/simplex/{config,logs}
+   ```
+
+2. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server:
+   ```sh
+   docker run -d \
+       -e addr="your_ip_or_domain" \
+       -e pass="password" \
+       -p 5223:5223 \
+       -v $HOME/simplex/config:/etc/opt/simplex:z \
+       -v $HOME/simplex/logs:/var/opt/simplex:z \
+       simplexchat/simplexmq
+   ```
+
+#### Ubuntu
+
+For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
+
+### Build from source
+
+#### Using Docker
+
+> **Please note:** to build the app use source code from [stable branch](https://github.com/simplex-chat/simplexmq/tree/stable).
+
+On Linux, you can build smp server using Docker.
+
+1. Build your `smp-server` image:
+
+   ```sh
+   git clone https://github.com/simplex-chat/simplexmq
+   cd simplexmq
+   git checkout stable
+   DOCKER_BUILDKIT=1 docker build -t smp-server -f ./build.Dockerfile .
+   ```
+
+2. Create `config` and `logs` directories:
+
+   ```sh
+   mkdir -p ~/simplex/{config,logs}
+   ```
+
+3. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server::
+   ```sh
+   docker run -d \
+       -e addr="your_ip_or_domain" \
+       -e pass="password" \
+       -p 5223:5223 \
+       -v $HOME/simplex/config:/etc/opt/simplex:z \
+       -v $HOME/simplex/logs:/var/opt/simplex:z \
+       smp-server
+   ```
+
+#### Using your distribution
+
+1. Install [Haskell GHCup](https://www.haskell.org/ghcup/), GHC 8.10.7 and cabal:
+
+   ```sh
+   curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
+   ghcup install ghc 8.10.7
+   ghcup install cabal
+   ghcup set ghc 8.10.7
+   ghcup set cabal
+   ```
+
+2. Build the project:
+
+   ```sh
+   git clone https://github.com/simplex-chat/simplexmq
+   cd simplexmq
+   git checkout stable
+   # On Ubuntu. Depending on your distribution, use your package manager to determine package names.
+   apt-get update && apt-get install -y build-essential libgmp3-dev zlib1g-dev
+   cabal update
+   cabal install
+   ```
 
 - Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
 
 - Run `smp-server start` to start SMP server, or you can configure a service manager to run it as a service.
 
+- Optionally, `smp-server` can be setup for having an onion address in `tor` network. See: [`scripts/tor`](./scripts/tor/). In this case, the server address can have both public and onion hostname pointing to the same server, to allow two people connect when only one of them is using Tor. The server address would be: `smp://<fingerprint>@<public_hostname>,<onion_hostname>`
+
 See [this section](#smp-server) for more information. Run `smp-server -h` and `smp-server init -h` for explanation of commands and options.
 
-[<img alt="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
+[<img alt="Linode" src="./img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
 
 ## Deploy SMP server on Linode
 
@@ -134,7 +218,7 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 
 Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
 
-[<img alt="DigitalOcean" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
+[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
 
 ## Deploy SMP server on DigitalOcean
 
@@ -162,12 +246,12 @@ smp-server init [-l] -n <fqdn>
 
 ## SMP server design
 
-![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
+![SMP server design](./design/server.svg)
 
 ## SMP agent design
 
-![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
+![SMP agent design](./design/agent2.svg)
 
 ## License
 
-[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)
+[AGPL v3](./LICENSE)

apps/ntf-server/Main.hs

@@ -1,15 +1,7 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
 module Main where
 
 import Control.Logger.Simple
-import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
-import Simplex.Messaging.Notifications.Server (runNtfServer)
-import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
-import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
-import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI)
-import System.FilePath (combine)
+import Simplex.Messaging.Notifications.Server.Main
 
 cfgPath :: FilePath
 cfgPath = "/etc/opt/simplex-notifications"
@@ -23,55 +15,4 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 main :: IO ()
 main = do
   setLogLevel LogDebug -- change to LogError in production
-  withGlobalLogging logCfg $ protocolServerCLI ntfServerCLIConfig runNtfServer
-
-ntfServerCLIConfig :: ServerCLIConfig NtfServerConfig
-ntfServerCLIConfig =
-  let caCrtFile = combine cfgPath "ca.crt"
-      serverKeyFile = combine cfgPath "server.key"
-      serverCrtFile = combine cfgPath "server.crt"
-   in ServerCLIConfig
-        { cfgDir = cfgPath,
-          logDir = logPath,
-          iniFile = combine cfgPath "ntf-server.ini",
-          storeLogFile = combine logPath "ntf-server-store.log",
-          caKeyFile = combine cfgPath "ca.key",
-          caCrtFile,
-          serverKeyFile,
-          serverCrtFile,
-          fingerprintFile = combine cfgPath "fingerprint",
-          defaultServerPort = "443",
-          executableName = "ntf-server",
-          serverVersion = "SMP notifications server v1.0.0",
-          mkIniFile = \enableStoreLog defaultServerPort ->
-            "[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\
-            \# The messages are not logged.\n"
-              <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n\n")
-              <> "[TRANSPORT]\n\
-                 \port: "
-              <> defaultServerPort
-              <> "\n\
-                 \websockets: off\n",
-          mkServerConfig = \storeLogFile transports _ ->
-            NtfServerConfig
-              { transports,
-                subIdBytes = 24,
-                regCodeBytes = 32,
-                clientQSize = 16,
-                subQSize = 64,
-                pushQSize = 128,
-                smpAgentCfg = defaultSMPClientAgentConfig,
-                apnsConfig = defaultAPNSPushClientConfig,
-                inactiveClientExpiration = Nothing,
-                storeLogFile,
-                resubscribeDelay = 50000, -- 50ms
-                caCertificateFile = caCrtFile,
-                privateKeyFile = serverKeyFile,
-                certificateFile = serverCrtFile
-              }
-        }
+  withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath

apps/smp-agent/Main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -6,8 +7,10 @@ module Main where
 
 import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
+import qualified Data.Map.Strict as M
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Server (runSMPAgent)
+import Simplex.Messaging.Client (defaultNetworkConfig)
 import Simplex.Messaging.Transport (TLS, Transport (..))
 
 cfg :: AgentConfig
@@ -16,8 +19,9 @@ cfg = defaultAgentConfig
 servers :: InitialAgentServers
 servers =
   InitialAgentServers
-    { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = []
+    { smp = M.fromList [(1, L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"])],
+      ntf = [],
+      netCfg = defaultNetworkConfig
     }
 
 logCfg :: LogConfig

apps/smp-server/Main.hs

@@ -1,20 +1,7 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-
 module Main where
 
 import Control.Logger.Simple
-import Data.Functor (($>))
-import Data.Ini (lookupValue)
-import Simplex.Messaging.Server (runSMPServer)
-import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
-import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
-import System.FilePath (combine)
+import Simplex.Messaging.Server.Main
 
 cfgPath :: FilePath
 cfgPath = "/etc/opt/simplex"
@@ -27,83 +14,5 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
-  setLogLevel LogInfo
-  withGlobalLogging logCfg . protocolServerCLI smpServerCLIConfig $ \cfg@ServerConfig {inactiveClientExpiration} -> do
-    putStrLn $ case inactiveClientExpiration of
-      Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
-      _ -> "not expiring inactive clients"
-    runSMPServer cfg
-
-smpServerCLIConfig :: ServerCLIConfig ServerConfig
-smpServerCLIConfig =
-  let caCrtFile = combine cfgPath "ca.crt"
-      serverKeyFile = combine cfgPath "server.key"
-      serverCrtFile = combine cfgPath "server.crt"
-   in ServerCLIConfig
-        { cfgDir = cfgPath,
-          logDir = logPath,
-          iniFile = combine cfgPath "smp-server.ini",
-          storeLogFile = combine logPath "smp-server-store.log",
-          caKeyFile = combine cfgPath "ca.key",
-          caCrtFile,
-          serverKeyFile,
-          serverCrtFile,
-          fingerprintFile = combine cfgPath "fingerprint",
-          defaultServerPort = "5223",
-          executableName = "smp-server",
-          serverVersion = "SMP server v" <> simplexMQVersion,
-          mkIniFile = \enableStoreLog defaultServerPort ->
-            "[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: " <> (if enableStoreLog then "on" else "off") <> "\n")
-              <> "# The messages are optionally saved and restored when the server restarts,\n\
-                 \# they are deleted after restarting.\n"
-              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n\n")
-              <> "[TRANSPORT]\n"
-              <> ("port: " <> defaultServerPort <> "\n")
-              <> "websockets: off\n\n"
-              <> "[INACTIVE_CLIENTS]\n\
-                 \# TTL and interval to check inactive clients\n\
-                 \disconnect: off\n"
-              <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
-              <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
-          mkServerConfig = \storeLogFile transports ini ->
-            ServerConfig
-              { transports,
-                tbqSize = 16,
-                serverTbqSize = 64,
-                msgQueueQuota = 128,
-                queueIdBytes = 24,
-                msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
-                caCertificateFile = caCrtFile,
-                privateKeyFile = serverKeyFile,
-                certificateFile = serverCrtFile,
-                storeLogFile,
-                storeMsgsFile =
-                  let messagesPath = combine logPath "smp-server-messages.log"
-                   in case lookupValue "STORE_LOG" "restore_messages" ini of
-                        Right "on" -> Just messagesPath
-                        Right _ -> Nothing
-                        -- if the setting is not set, it is enabled when store log is enabled
-                        _ -> storeLogFile $> messagesPath,
-                allowNewQueues = True,
-                messageExpiration = Just defaultMessageExpiration,
-                inactiveClientExpiration =
-                  if lookupValue "INACTIVE_CLIENTS" "disconnect" ini == Right "on"
-                    then
-                      Just
-                        ExpirationConfig
-                          { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
-                            checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
-                          }
-                    else Nothing,
-                logStatsInterval = Just 86400, -- seconds
-                logStatsStartTime = 0, -- seconds from 00:00 UTC
-                serverStatsFile = Just $ combine logPath "smp-server-stats.log",
-                smpServerVRange = supportedSMPServerVRange
-              }
-        }
+  setLogLevel LogDebug
+  withGlobalLogging logCfg $ smpServerCLI cfgPath logPath

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

build.Dockerfile

@@ -0,0 +1,51 @@
+FROM ubuntu:focal AS final
+FROM ubuntu:focal AS build
+
+### Build stage
+
+# Install curl and git and smp-related dependencies
+RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev
+
+# Install ghcup
+RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghcup && \
+    chmod +x /usr/bin/ghcup
+
+# Install ghc
+RUN ghcup install ghc 8.10.7
+# Install cabal
+RUN ghcup install cabal
+# Set both as default
+RUN ghcup set ghc 8.10.7 && \
+    ghcup set cabal
+
+COPY . /project
+WORKDIR /project
+
+# Adjust PATH
+ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
+
+# Compile smp-server
+RUN cabal update
+RUN cabal install
+
+### Final stage
+
+FROM final
+
+# Install OpenSSL dependency
+RUN apt-get update && apt-get install -y openssl
+
+# Copy compiled smp-server from build stage
+COPY --from=build /root/.cabal/bin/smp-server /usr/bin/smp-server
+
+# Copy our helper script
+COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
+
+# Open smp-server listening port
+EXPOSE 5223
+
+# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
+STOPSIGNAL SIGINT
+
+# Finally, execute helper script
+ENTRYPOINT [ "/usr/bin/entrypoint" ]

cabal.project

@@ -1,6 +1,28 @@
 packages: .
+-- packages: . ../direct-sqlcipher ../sqlcipher-simple
+-- packages: . ../hs-socks
 
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/aeson.git
     tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
+
+source-repository-package
+    type: git
+    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
+    tag: 34309410eb2069b029b8fc1872deb1e0db123294
+
+source-repository-package
+    type: git
+    location: https://github.com/simplex-chat/sqlcipher-simple.git
+    tag: 5e154a2aeccc33ead6c243ec07195ab673137221

download.Dockerfile

@@ -0,0 +1,20 @@
+FROM ubuntu:focal
+
+# Install curl
+RUN apt-get update && apt-get install -y curl
+
+# Download latest smp-server release and assign executable permission
+RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/smp-server-ubuntu-20_04-x86-64 -o /usr/bin/smp-server && \
+	chmod +x /usr/bin/smp-server
+
+# Copy our helper script
+COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
+
+# Open smp-server listening port
+EXPOSE 5223
+
+# SimpleX requires using SIGINT to correctly preserve undelivered messages and restore them on restart
+STOPSIGNAL SIGINT
+
+# Finally, execute helper script
+ENTRYPOINT [ "/usr/bin/entrypoint" ]

img/linode.svg

@@ -1 +1 @@
-<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 506.94 131.5"><path d="m109.65 58.21-18.21-10.07-15.37 9.38-.19 9.59-7.47-4.92-10.16 6.19-.44-10.48-10.48-7 10-5.17c-.08 0 0 1-1.48-34.34l-23.65-11.39-32.2 10 7.19 34.63 10.81 8.37-8.22 3.9 5.37 26.1 7.55 7.09-5.4 3.29 4.19 20.18 16.94 17.94c.08-.1 1.78-1.41 21.79-17.32l-.58-13.71 8.58 7.28c.12-.12 1.84-1.39 17.56-13.89l.61-10.14 6.48 4.5c.13-.12 1.58-1.22 14.26-11.33z" fill="#231f20"/><path d="m94.54 69 15.11-10.79-18.21-10.07-15.37 9.38z"/><path d="m92.87 88.2 1.67-19.2-18.47-11.48-.38 18.75z" fill="#004b16"/><path d="m68.22 107.73v-19.89l-18.66-14.15 1.47 19.54z" fill="#004b16"/><path d="m68.22 87.84 18.74-13.43-18.55-12.22-18.85 11.5z"/><path d="m38.43 131.48-2.98-20.32-18.15-17.8 4.19 20.18z" fill="#004b16"/><path d="m35.45 111.16 23.91-17.06-18.53-15.09-23.53 14.35z"/><path d="m33.9 100.6-3.94-26.88-20.22-16.81 5.41 26.07z" fill="#004b16"/><path d="m29.96 73.72 27.85-15.82-20.8-13.94-27.27 12.95z"/><path d="m28.07 60.88-5.4-36.81-22.67-14.06 7.19 34.62z" fill="#004b16"/><path d="m22.67 24.07 33.14-12.7-23.61-11.37-32.2 10.01z"/><g fill="#1cb35c"><path d="m107.13 76.87c-14.02 11.13-14.33 11.33-14.26 11.33 1.74-20.1 1.59-19.2 1.67-19.2 16-11.45 15-10.79 15.11-10.79z"/><path d="m85.78 93.84c-17.35 13.8-17.63 13.89-17.56 13.89-.17-20.82-.07-19.89 0-19.89 20-14.3 18.67-13.43 18.74-13.43z"/><path d="m60.22 114.16c-21.66 17.22-21.86 17.32-21.79 17.32-3.07-20.94-3-20.32-3-20.32 25.47-18.16 23.86-17.06 23.93-17.06z"/><path d="m55.81 11.37c1.52 35.37 1.4 34.34 1.48 34.34-28.66 14.89-29.29 15.17-29.22 15.17-5.52-37.63-5.47-36.81-5.4-36.81z"/><path d="m57.81 57.9c1.15 26.81 1 25.88 1.11 25.88-24.81 16.67-25.09 16.82-25 16.82-4-27.58-4-26.88-3.94-26.88z"/></g><path xmlns="http://www.w3.org/2000/svg" d="m151.61 14.24 16.58-4v79.88q0 13.13 7.83 15.65-3.84 7.31-13.13 7.3-11.28 0-11.28-15.66z"/><path d="m186.66 111.72v-57.42h-9.08v-13.6h25.86v71zm8.56-98.54a9.62 9.62 0 1 1 -9.62 9.62 9.63 9.63 0 0 1 9.62-9.62z"/><path d="m262.94 111.74v-41.06c0-6.05-1.16-10.48-3.48-13.26s-6.11-4.18-11.37-4.18a17.74 17.74 0 0 0 -7.8 2.06 18 18 0 0 0 -6.46 5.1v51.34h-16.59v-71h11.94l3 6.64q6.76-8 20-8 12.66 0 20 7.59t7.33 21.19v43.58z"/><path d="m288.42 76.06q0-16.26 9.38-26.47t24.77-10.21q16.19 0 25.14 9.82t9 26.86q0 17-9.12 27t-25 10q-16.18 0-25.17-10.12t-9-26.88zm17.24 0q0 23.47 16.91 23.48a14.54 14.54 0 0 0 12.31-6.11q4.55-6.09 4.54-17.37 0-23.14-16.85-23.15a14.61 14.61 0 0 0 -12.33 6.09q-4.58 6.11-4.58 17.06z"/><path d="m412.37 111.74v-4.31c-1.37 1.5-3.71 2.82-7 3.95a31.33 31.33 0 0 1 -10.15 1.69q-14.87 0-23.38-9.42t-8.52-26.27q0-16.84 9.78-27.42a32 32 0 0 1 24.51-10.58 32.37 32.37 0 0 1 14.72 3.32v-28.46l16.58-4v101.5zm0-54.06a17.6 17.6 0 0 0 -11.07-4.24q-10 0-15.33 6.07t-5.37 17.41q0 22.15 21.36 22.15a16.11 16.11 0 0 0 5.87-1.42c2.32-1 3.83-1.92 4.54-2.89z"/><path d="m505.55 81.3h-50.74q.46 8.49 5.83 13.2t14.46 4.7q11.34 0 17.25-5.9l6.43 12.7q-8.75 7.09-26.13 7.1-16.25 0-25.7-9.52t-9.45-26.58q0-16.78 10.38-27.2a33.91 33.91 0 0 1 24.9-10.41q15.45 0 24.81 9.22t9.35 23.48a46.28 46.28 0 0 1 -1.39 9.21zm-50.15-12.47h34.89q-1.73-15.58-17.24-15.59-14.2 0-17.65 15.59z"/></svg>
+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 506.94 131.5"><path d="m109.65 58.21-18.21-10.07-15.37 9.38-.19 9.59-7.47-4.92-10.16 6.19-.44-10.48-10.48-7 10-5.17c-.08 0 0 1-1.48-34.34l-23.65-11.39-32.2 10 7.19 34.63 10.81 8.37-8.22 3.9 5.37 26.1 7.55 7.09-5.4 3.29 4.19 20.18 16.94 17.94c.08-.1 1.78-1.41 21.79-17.32l-.58-13.71 8.58 7.28c.12-.12 1.84-1.39 17.56-13.89l.61-10.14 6.48 4.5c.13-.12 1.58-1.22 14.26-11.33z" fill="#231f20"/><path d="m94.54 69 15.11-10.79-18.21-10.07-15.37 9.38z"/><path d="m92.87 88.2 1.67-19.2-18.47-11.48-.38 18.75z" fill="#004b16"/><path d="m68.22 107.73v-19.89l-18.66-14.15 1.47 19.54z" fill="#004b16"/><path d="m68.22 87.84 18.74-13.43-18.55-12.22-18.85 11.5z"/><path d="m38.43 131.48-2.98-20.32-18.15-17.8 4.19 20.18z" fill="#004b16"/><path d="m35.45 111.16 23.91-17.06-18.53-15.09-23.53 14.35z"/><path d="m33.9 100.6-3.94-26.88-20.22-16.81 5.41 26.07z" fill="#004b16"/><path d="m29.96 73.72 27.85-15.82-20.8-13.94-27.27 12.95z"/><path d="m28.07 60.88-5.4-36.81-22.67-14.06 7.19 34.62z" fill="#004b16"/><path d="m22.67 24.07 33.14-12.7-23.61-11.37-32.2 10.01z"/><g fill="#1cb35c"><path d="m107.13 76.87c-14.02 11.13-14.33 11.33-14.26 11.33 1.74-20.1 1.59-19.2 1.67-19.2 16-11.45 15-10.79 15.11-10.79z"/><path d="m85.78 93.84c-17.35 13.8-17.63 13.89-17.56 13.89-.17-20.82-.07-19.89 0-19.89 20-14.3 18.67-13.43 18.74-13.43z"/><path d="m60.22 114.16c-21.66 17.22-21.86 17.32-21.79 17.32-3.07-20.94-3-20.32-3-20.32 25.47-18.16 23.86-17.06 23.93-17.06z"/><path d="m55.81 11.37c1.52 35.37 1.4 34.34 1.48 34.34-28.66 14.89-29.29 15.17-29.22 15.17-5.52-37.63-5.47-36.81-5.4-36.81z"/><path d="m57.81 57.9c1.15 26.81 1 25.88 1.11 25.88-24.81 16.67-25.09 16.82-25 16.82-4-27.58-4-26.88-3.94-26.88z"/></g><path xmlns="http://www.w3.org/2000/svg" d="m151.61 14.24 16.58-4v79.88q0 13.13 7.83 15.65-3.84 7.31-13.13 7.3-11.28 0-11.28-15.66z"/><path d="m186.66 111.72v-57.42h-9.08v-13.6h25.86v71zm8.56-98.54a9.62 9.62 0 1 1 -9.62 9.62 9.63 9.63 0 0 1 9.62-9.62z"/><path d="m262.94 111.74v-41.06c0-6.05-1.16-10.48-3.48-13.26s-6.11-4.18-11.37-4.18a17.74 17.74 0 0 0 -7.8 2.06 18 18 0 0 0 -6.46 5.1v51.34h-16.59v-71h11.94l3 6.64q6.76-8 20-8 12.66 0 20 7.59t7.33 21.19v43.58z"/><path d="m288.42 76.06q0-16.26 9.38-26.47t24.77-10.21q16.19 0 25.14 9.82t9 26.86q0 17-9.12 27t-25 10q-16.18 0-25.17-10.12t-9-26.88zm17.24 0q0 23.47 16.91 23.48a14.54 14.54 0 0 0 12.31-6.11q4.55-6.09 4.54-17.37 0-23.14-16.85-23.15a14.61 14.61 0 0 0 -12.33 6.09q-4.58 6.11-4.58 17.06z"/><path d="m412.37 111.74v-4.31c-1.37 1.5-3.71 2.82-7 3.95a31.33 31.33 0 0 1 -10.15 1.69q-14.87 0-23.38-9.42t-8.52-26.27q0-16.84 9.78-27.42a32 32 0 0 1 24.51-10.58 32.37 32.37 0 0 1 14.72 3.32v-28.46l16.58-4v101.5zm0-54.06a17.6 17.6 0 0 0 -11.07-4.24q-10 0-15.33 6.07t-5.37 17.41q0 22.15 21.36 22.15a16.11 16.11 0 0 0 5.87-1.42c2.32-1 3.83-1.92 4.54-2.89z"/><path d="m505.55 81.3h-50.74q.46 8.49 5.83 13.2t14.46 4.7q11.34 0 17.25-5.9l6.43 12.7q-8.75 7.09-26.13 7.1-16.25 0-25.7-9.52t-9.45-26.58q0-16.78 10.38-27.2a33.91 33.91 0 0 1 24.9-10.41q15.45 0 24.81 9.22t9.35 23.48a46.28 46.28 0 0 1 -1.39 9.21zm-50.15-12.47h34.89q-1.73-15.58-17.24-15.59-14.2 0-17.65 15.59z"/></svg>

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 3.0.0
+version: 5.0.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -38,31 +38,33 @@ dependencies:
   - cryptonite >= 0.27 && < 0.30
   - cryptostore == 0.2.*
   - data-default == 0.7.*
-  - direct-sqlite == 2.3.*
+  - direct-sqlcipher == 2.3.*
   - 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.*
+  - 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.*
+  - network-transport == 0.5.4
   - optparse-applicative >= 0.15 && < 0.17
   - QuickCheck == 2.14.*
   - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
-  - sqlite-simple == 0.4.*
+  - 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.5.7 && < 1.6
+  - tls >= 1.6.0 && < 1.7
   - transformers == 0.5.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
@@ -70,6 +72,7 @@ dependencies:
   - x509 == 1.7.*
   - x509-store == 1.6.*
   - x509-validation == 1.6.*
+  - yaml == 0.11.*
 
 flags:
   swift:
@@ -102,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
@@ -110,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:
@@ -120,6 +139,8 @@ tests:
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
       - QuickCheck == 2.14.*
+      - silently == 1.2.*
+      - main-tester == 0.2.*
       - timeit == 2.0.*
 
 ghc-options:

protocol/simplex-messaging.md

@@ -51,6 +51,8 @@ It's designed with the focus on communication security and integrity, under the
 
 It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
 
+This document describes SMP protocol versions 3 and 4, the previous versions are discontinued.
+
 ## Introduction
 
 The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
@@ -362,15 +364,16 @@ The clients can optionally instruct a dedicated push notification server to subs
 
 [`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
 
-## SMP Transmission structure
+## SMP Transmission andtransport block structure
 
 Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
 
+From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission.
 Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
 
 In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
 
-```
+```abnf
 paddedString = originalLength string pad
 originalLength = 2*2 OCTET
 pad = N*N"#" ; where N = paddedLength - originalLength - 2
@@ -380,9 +383,9 @@ paddedNotation = <padded(string, paddedLength)>
 ; paddedLength - required length after padding, including 2 bytes for originalLength
 ```
 
-Each transmission between the client and the server must have this format/syntax:
+Each transmission/block for SMP v3 between the client and the server must have this format/syntax:
 
-```
+```abnf
 paddedTransmission = <padded(transmission), 16384>
 transmission = [signature] SP signed
 signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
@@ -399,6 +402,16 @@ encoded = <base64 encoded binary>
 
 `base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
 
+Transport block for SMP v4 has this syntax:
+
+```abnf
+paddedTransportBlock = <padded(transportBlock), 16384>
+transportBlock = transmissionCount transmissions
+transmissionCount = 1*1 OCTET ; equal or greater than 1
+transmissions = transmissionLength transmission [transmissions]
+transmissionLength = 2*2 OCTET ; word16 encoded in network byte order
+```
+
 ## SMP commands
 
 Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].

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

@@ -0,0 +1,160 @@
+# SimpleX File Transfer protocol
+
+## Problem
+
+Sending files as currently implemented in SimpleX Chat is inefficient for these reasons:
+
+1. Slow: message delivery requires acknowledgement for each message before the server sends the next message.
+2. Not fully asynchronous:
+   a. SMP queue size is limited, so the whole file cannot be sent/stored in server memory.
+   b. Recipient needs to accept the file before it is sent.
+3. No broadcast: sending the same file to multiple recipients requires sending it multiple times.
+
+## Possible solutions
+
+These problems could be solved within SMP protocol:
+
+- streaming messages without waiting for acknowledgements.
+- bigger queue sizes stored on hard drive and accepting large files without waiting for the recipient confirmation.
+- adding broadcast to SMP servers.
+
+These solution are complex and they do not scale well.
+
+Another approach would be adopting some open-source file storage, possibly S3-compatible, to host files while "in transit". The downsides are:
+
+1. Missing features. S3-compatible file servers require a service layer that we would need to develop to manage user accounts and permissions. There are solutions that allow self-registering users and uploading files without service layer, but they are not flexible enough in managing policies for these files.
+2. Limited meta-data protection, both on the application and on transport layer: same address for sending and receiving a file, file size is known to the server, etc.
+3. More difficult to self-host for the users when the server has 2 components (a 3rd party solution with our service component).
+
+We are not considering P2P solutions because of their bad meta-data privacy and requirement of having a single network - the same reason why P2P design is not used for SimpleX messaging network.
+
+A proposed solution is to develop a file hosting service (SimpleX File Transfer service) that would have better meta-data protection and functionality than the alternatives, using the ideas from SMP protocol design.
+
+The parameters of the solution would be:
+
+1. The server does not have knowledge of the users and actual files – only anonymously uploaded fixed-size chunks (considered 8Mb, maybe we should allow 2 sizes, e.g. 1Mb and 8Mb).
+2. The server should allow broadcast, so that a chunk can be downloaded by multiple recipients.
+3. There should be no identifiers and ciphertext in common inside TLS between sender and recipient traffic, and between the traffic of different recipients of the same file. This approach can be extended to support public chunks that have persistent identifiers.
+4. The server should prevent multiple uploads of the same chunk. This can be extended to allow multiple downloads from the same persistent address.
+5. Clients can send the chunks from the same file via multiple servers, both by splitting chunks between them and for redundancy.
+
+## Design approach
+
+File transfer servers will be chosen by file senders. The servers will allow senders to anonymously upload fixed-size file chunks.
+
+### Transport protocol
+
+- binary-encoded commands sent as fixed-size padded block in the body of HTTP2 POST request, similar to SMP and notifications server protocol transmission encodings.
+- HTTP2 POST with a fixed size padded block body for file upload and download.
+
+Block size - 4096 bytes (it would fit ~120 Ed25519 recipient keys).
+
+The reasons to use HTTP2:
+
+- avoid the need to have two hostnames (or two different ports) for commands and file uploads.
+- compatibility with the existing HTTP2 client libraries.
+
+The reason not to use JSON bodies:
+
+- bigger request size, so fewer recipient keys would fit in a single request
+- signature over command has to be outside of JSON anyway.
+
+The reason not to use URI segments / HTTP verbs / REST semantics is to have consistent request size.
+
+### Required server commands:
+
+- File sender:
+  - create file chunk record.
+    - Parameters:
+      - Ed25519 key for subsequent sender commands and Ed25519 keys for commands of each recipient.
+      - chunk size.
+    - Response:
+      - chunk ID for the sender and different IDs for all recipients.
+  - add recipients to file chunk
+    - Parameters:
+      - sender's chunk ID
+      - Ed25519 keys for commands of each recipient.
+    - Response:
+      - chunk IDs for new recipients.
+  - upload file chunk.
+  - delete file chunk (invalidates all recipient IDs).
+- File recipient:
+  - download file chunk:
+    - chunk ID
+    - DH key for additional encryption of the chunk.
+    - command should be signed with the key passed by the sender when creating chunk record.
+  - delete file chunk ID (only for one recipient): signed with the same key.
+
+### Storage model
+
+Same as for SMP and notifications server - in-memory storage of the records, with adding to append-only log, restored and compacted on server restart.
+
+### Sending file
+
+To send the file, the sender will:
+
+- compute SHA512 digest
+- pad the file to match the whole number of chunks in size,
+- encrypt it with a randomly chosen symmetric key and IV (e.g., using NaCL crypto_secretbox),
+- split into fixed size chunks
+- upload each chunk to a randomly chosen server.
+
+The sending client should generate more per-recipient keys than the actual number of recipients, possibly rounding up to a power of 2, to conceal the actual number of intended recipients.
+
+Then the sending client will combine addresses of all chunks and other information into "file description", different for each file recipient, that will include:
+
+- an encryption key that was used to encrypt the file (the same for all recipients).
+- file SHA512 digest
+- list of chunk descriptions; information for each chunk:
+  - private Ed25519 key to sign commands for file transfer server.
+  - chunk address (server host and chunk ID).
+  - chunk sha512 digest
+
+To reduce the size, chunk descriptions will be grouped by the server host.
+
+This "file description" itself will be sent as a small file over an authenticated channel, to prevent file description modification. To estimate its size:
+
+- each chunk \* redundancy per chunk, assuming chunks are grouped per server:
+  - 1-based chunk number in the file - 8 bytes (including any overhead)
+  - Ed25519 key (different for each recipient / chunk combination) - 32 bytes \* 4/3 (base64, assuming text encoding)
+  - chunk ID (different for each recipient) - 64 bytes \* 4/3
+  - optional (only in the first chunk occurence) chunk sha512 digests - 64 bytes \* 4/3
+- server addresses - say, 128 bytes per server
+- sha512 digest - 64 bytes \* 4/3
+- encryption key - 32 bytes \* 4/3
+- IV - 32 bytes \* 4/3
+- encoding overhead - say, 256 bytes
+
+For 1gb file, sent via 4 different servers, in 8Mb chunks, with redundancy 2, the size of "file description", assuming text encoding, will be ~45kb (`128 * (8 + 32 + 64) * 2 * 4/3 + 128 * 64 * 4/3 + 128 * 4 + (64 + 32 + 32) * 4/3 + 256`).
+
+File description format (yml):
+
+```
+name: file.ext
+size: 33200000
+chunk: 8mb
+hash: abc=
+key: abc=
+iv: abc=
+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=:2mb]
+  - server: xftp://[email protected]
+    chunks: [1:abc=:def=, 4:abc=:def=]
+  - server: xftp://[email protected]
+    chunks: [2:abc=:def=, 3:abc=:def=]
+```
+
+This file description is sent to all recipients via normal messages, split to 15780 byte chunks if needed.
+
+### Receiving file
+
+Having received the description, the recipient will:
+
+- download all chunks falling back to secondary servers, if needed
+- combine the chunks into a file
+- decrypt the file
+- un-pad it
+- validate file digest

rfcs/2022-12-27-queue-quota.md

@@ -0,0 +1,20 @@
+# SMP and SMP agent protocol extensions to manage queue quotas
+
+## Problem
+
+SMP servers define a limit on the number of messages that can be stored on the server. When the sender reaches this limit, they continue trying to send the message with exponential back off, until the server allows it. To reduce the traffic we added expiration on unsent messages of 2 days that:
+
+- adds its own set of problems because of expired control messages - e.g., group fragmentation.
+- doesn't solve problem of traffic in active groups with many inactive members - there are still too many retries in queues that reached capacity.
+
+## Solution
+
+Sending agent permanently stops trying to send messages having received `ERR QUOTA` (or, for the period of clients migration, increases TTL much more than in cases of network errors).
+
+Add SMP server event that means "quota reached" (e.g. `QTA` or `MSG QUOTA`) - it will be delivered to the recipient once all messages are retrieved at the same point in message stream where the sender received `ERR QUOTA`. Alternatively, it could be a message flag that is set on the last message in the queue at a point the sender received `ERR QUOTA`.
+
+Add SMP agent message that means "quota available, resume sending" (e.g. `A_QTA` or `A_RESUME`) – the receiving agent will send it via the reply queue to the sending agent that will resume sending messages at this point.
+
+Possibly, increase TTL for local messages to 30 days. That might require separately addressing the problem of permanently failing servers.
+
+We discussed a possible solution of merging all messages to one server into one delivery queue, so that having multiple failing queues on this server will not result in multiple connection attempts, and this proposal also answers the question what to do with the messages when quota is exceeded - the whole queue can be marked as suspended, and processed separately from others - TBD.

rfcs/done/2022-07-22-access-via-tor.md

@@ -0,0 +1,26 @@
+# Accessing SMP servers via Tor
+
+## Problem
+
+While SMP protocol is focussed on minimizing application-level meta-data by using pair-wise identifiers instead of user profile identifiers, it is important for many users to protect their IP addresses.
+
+Further, even if IP addresses are hidden by onion routing, clients should be able to choose to use a separate TCP connection to subscribe to each queue, even though it increases traffic and battery consumption, as otherwise the servers can observe multiple queues accessed by the same client.
+
+## Solution and requirements
+
+While some users may want to access SMP servers via tor, some other users (even their contacts) may want the opposite - e.g., if they use the network when accessing Tor would be suspicious (or blocked).
+
+Therefore we need to support the connections when one of the user accesses the same server via Tor (and, possibly, via onion address), while another user accesses this server without Tor.
+
+At the same time the user accessing the server via Tor may not want that their contacts access this server without Tor, and it also may be possible that the server is not available under a normal (not .onion) address.
+
+The proposed options for connecting via Tor are:
+
+1. Access servers via Socks proxy: no/yes (specify port?)
+2. Use .onion addresses: no/when available/warn/always
+3. Require senders to use .onion addresses: yes/no
+4. Use separate TCP connection for each queue
+
+While it should be possible for SMP servers to have two addresses (with and without Tor), the queues should only use one server address - if the queue started being accessed via .onion address it should not be possible to access it via a normal address. Queue addresses in connection invitations should support dual server addresses (when senders are not required ot use .onion address).
+
+At the same time, the queue with the normal addresses can be accessed with and without Tor, depending on the current device settings.

rfcs/done/2022-08-14-queue-rotation.md

@@ -0,0 +1,53 @@
+# SMP queue rotation and redundancy
+
+## Problem
+
+1. Long term usage of the queue allows the servers to analyze long term traffic patterns.
+
+2. If the user changes the configured SMP server(s), the previously created contacts do not migrate to the new server(s).
+
+3. Server can lose messages.
+
+## Solution
+
+Additional messages exchanged by SMP agents to negotiate addition and removal of queues to the connection.
+
+This approach allows for both rotation and redundancy, as changing queue will be done be adding a queue and then removing the existing queue.
+
+The reason for this approach is that otherwise it's non-trivial to switch from one queue to another without losing messages or delivering them out of order, it's easier to have messages delivered via both queues during the switch, however short or long time it is.
+
+### Messages
+
+Additional agent messages required for the protocol:
+
+    QADD_ -> "QA"
+    QKEY_ -> "QK"
+    QUSE_ -> "QU"
+    QTEST_ -> "QT"
+
+`QADD`: add the new queue address(es), the same format as `REPLY` message, encoded as `QA`.
+
+`QKEY`: pass sender's key via existing connection (SMP confirmation message will not be used, to avoid the same "race" of the initial key exchange that would create the risk of intercepting the queue for the attacker), encoded as `QK`.
+
+`QUSE`: instruct the sender to use the new queue with sender's queue ID as parameter, encoded as `QU`.
+
+`QTEST`: send test message to the new connection, encoded as `QT`. Any other message can be sent if available to continue rotation, the absence of this message is not an error. Once this message is successfully sent the sender will stop using the old queue. Once this message (or any other message in the new queue) is received, the recipient will stop using the old queue and delete it.
+
+### Protocol
+
+```
+participant A as Alice
+participant B as Bob
+participant R as Server that has A's receive queue
+participant S as Server that has A's send queue (B's receive queue)
+participant R' as Server that hosts the new A's receive queue
+
+A ->> R': create new queue
+A ->> S ->> B: QADD (R'): snd address of the new queue(s)
+B ->> S(R) ->> A: QKEY (R'): sender's key for the new queue(s) (to avoid the race of SMP confirmation for the initial exchange)
+A ->> S(R'): secure new queue
+A ->> S ->> B: QUSE (R'): instruction to use new queue(s)
+B ->> S(R') ->> A: QTEST
+A ->> S(R): DEL: delete the old queue
+B ->> S(R') ->> A: send all new messages to the new queue
+```

rfcs/done/2022-11-11-smp-basic-auth.md

@@ -0,0 +1,27 @@
+# SMP Basic Auth
+
+## Problem
+
+Users who host their own servers do not want unknown people to be able to create messaging queues on their servers after discovering server address in groups or after making a connection. As the number of self-hosted servers is growing it became more important than it was when we excluded it from the original design.
+
+## Solution
+
+Single access password that can be optionally included in server address that is passed to app configuration. It will not be allowed in the existing contexts (and parsing will fail), to avoid accidentally leaking it. Server address with password will look this way: `smp://fingerprint:password@hosts`
+
+## Implementation plan
+
+1. A separate type to include server and password, so it can only be used where allowed.
+
+2. Server password to create queues will be configured in TRANSPORT section of INI file, as `create_password` parameter.
+
+3. The password will only be required in server configuration/address to create queues only, it won't be required for other receiving queue operations on already existing queues.
+
+4. If new command is attempted in the session that does not allow creating queues, the server will send `ERR AUTH` response
+
+5. Passing password to the server can be done in one of the several ways, we need to decide:
+
+  - as a parameter of NEW command. Pros: a local change, that only needs checking when queue is created. Cons: protocol version change.
+  - as a separate command AUTH. Pros: allows to include additional parameters and potentially be extended beyond basic auth. Cons: more complex to manage server state, can be more difficult syntax in the future, if extended.
+  - as part of handshake (we currently ignore the unparsed part of handshake block, so it can be extended). Pros: probably, the simplest, and independent of the commands protocol – establishes create permission for the current session. Cons: the client won't know about whether it is able to create the queue until it tries (same as in case 1).
+
+  My preference is the last option. As a variant of the last option, we can add a server response/message that includes permission to create queues - it will only be sent to the clients who pass credential in handshake - that might simplify testing server connection (we currently do not do it). It might be unnecessary, as we could simply create and delete queue in case credential is passed as part of testing connection (and even sending a message to it).

scripts/docker/entrypoint

@@ -0,0 +1,29 @@
+#!/usr/bin/env sh
+confd="/etc/opt/simplex"
+logd="/var/opt/simplex/"
+
+# Check if server has been initialized
+if [ ! -f "$confd/smp-server.ini" ]; then
+  # If not, determine ip or domain
+  case $addr in
+    '') printf "Please specify \$addr environment variable.\n"; exit 1 ;;
+    *[a-zA-Z]*) set -- -n $addr ;;
+    *) set -- --ip $addr ;;
+  esac
+
+  case $pass in
+    '') set -- "$@" --no-password ;;
+    *) set -- "$@" --password $pass ;;
+  esac
+
+  smp-server init -y -l "$@"
+fi
+
+# backup store log
+[ -f "$logd/smp-server-store.log" ] && cp "$logd"/smp-server-store.log "$logd"/smp-server-store.log.bak
+# rotate server log
+[ -f "$logd/smp-server.log" ] && mv "$logd"/smp-server.log "$logd"/smp-server-"$(date +'%FT%T')".log
+
+# Finally, run smp-sever. Notice that "exec" here is important:
+# smp-server replaces our helper script, so that it can catch INT signal
+exec smp-server start > "$logd"/smp-server.log 2>&1

scripts/ntf-server-linode.sh

@@ -1,8 +1,8 @@
 #!/bin/bash
 
+# <UDF name="enable_store_log" label="Store log - persist notification subscriptions to append only log and restore them upon server restart." default="on" oneof="on, off" />
 # <UDF name="api_token" label="Linode API token - enable Linode to create tags with server address, fingerprint and version. Note: minimal permissions token should have are read/write access to `linodes` (to create tags) and `domains` (to add A record for the third level domain if FQDN is provided)." default="" />
-# TODO review
-# <UDF name="fqdn" label="FQDN (Fully Qualified Domain Name) - provide third level domain name (e.g. smp.example.com). If provided use `smp://fingerprint@FQDN` as server address in the client. If FQDN is not provided use `smp://fingerprint@IP` instead." default="" />
+# <UDF name="fqdn" label="FQDN (Fully Qualified Domain Name) - provide third level domain name (e.g. ntf.example.com). If provided use `ntf://fingerprint@FQDN` as server address in the client. If FQDN is not provided use `ntf://fingerprint@IP` instead." default="" />
 # <UDF name="apns_key_id" label="APNS key ID." default="" />
 
 # Log all stdout output to stackscript.log
@@ -74,6 +74,8 @@ ntf-server --version
 # Initialize server
 init_opts=()
 
+[[ $ENABLE_STORE_LOG == "on" ]] && init_opts+=(-l)
+
 ip_address=$(curl ifconfig.me)
 init_opts+=(--ip $ip_address)
 
@@ -85,10 +87,6 @@ ntf-server init "${init_opts[@]}"
 fingerprint=$(cat /etc/opt/simplex-notifications/fingerprint)
 
 # Determine server address to specify in welcome script and Linode tag
-# ! If FQDN was provided and used as part of server initialization, server's certificate will not pass validation at client
-# ! if client tries to connect by server's IP address, so we have to specify FQDN as server address in Linode tag and
-# ! in welcome script regardless of creation of A record in Linode
-# ! https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
 if [[ -n "$FQDN" ]]; then
   server_address=$FQDN
 else
@@ -98,7 +96,6 @@ fi
 # Set up welcome script
 on_login_script="/opt/simplex-notifications/on_login.sh"
 
-# TODO fix address
 # / Welcome script
 cat > $on_login_script << EOF
 #!/bin/bash
@@ -109,7 +106,7 @@ server_address=\$2
 cat << EOF2
 ********************************************************************************
 
-SimpleX notifications server address: smp://\$fingerprint@\$server_address
+SimpleX notifications server address: ntf://\$fingerprint@\$server_address
 Check server status with: systemctl status ntf-server
 
 To keep this server secure, the UFW firewall is enabled.

scripts/smp-server-linode.sh

@@ -86,10 +86,6 @@ smp-server init "${init_opts[@]}"
 fingerprint=$(cat /etc/opt/simplex/fingerprint)
 
 # Determine server address to specify in welcome script and Linode tag
-# ! If FQDN was provided and used as part of server initialization, server's certificate will not pass validation at client
-# ! if client tries to connect by server's IP address, so we have to specify FQDN as server address in Linode tag and
-# ! in welcome script regardless of creation of A record in Linode
-# ! https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
 if [[ -n "$FQDN" ]]; then
   server_address=$FQDN
 else

scripts/tor/README.md

@@ -0,0 +1,37 @@
+1. Install `tor` following [official guide](https://community.torproject.org/onion-services/setup/install/).
+
+2. Modify `/etc/tor/torrc` configuration file:
+
+```sh
+...
+# Disable anonymous mode for better connectivity
+## Needed for HiddenServiceNonAnonymousMode
+SOCKSPort 0
+## Needed for HiddenServiceSingleHopMode
+HiddenServiceNonAnonymousMode 1
+## Flag to disable anonymous mode
+## This option reduces the latency of server connection, but it makes server itself not anonymous,
+## it only protects the anonymity of the users connecting to the server.
+## In case your server address has both public and onion hostnames it is not anonymous anyway,
+## so this is what you want.
+HiddenServiceSingleHopMode 1
+
+# Specify folder for smp-tor
+## Folder for keys, address, etc.
+HiddenServiceDir /var/lib/tor/simplex-smp/
+## Map smp port (5223) to tor
+HiddenServicePort 5223 localhost:5223
+...
+```
+
+3. Restart `tor` system service:
+
+```
+sudo systemctl restart tor
+```
+
+4. Onion address can be obtained from following file:
+
+```sh
+sudo cat /var/lib/tor/simplex-smp/hostname
+```

simplexmq.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.1.
 --
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        3.0.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,9 +34,23 @@ 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
+      Simplex.Messaging.Agent.Lock
       Simplex.Messaging.Agent.NtfSubSupervisor
       Simplex.Messaging.Agent.Protocol
       Simplex.Messaging.Agent.QueryString
@@ -50,9 +64,20 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
+      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
@@ -60,7 +85,9 @@ library
       Simplex.Messaging.Notifications.Protocol
       Simplex.Messaging.Notifications.Server
       Simplex.Messaging.Notifications.Server.Env
+      Simplex.Messaging.Notifications.Server.Main
       Simplex.Messaging.Notifications.Server.Push.APNS
+      Simplex.Messaging.Notifications.Server.Stats
       Simplex.Messaging.Notifications.Server.Store
       Simplex.Messaging.Notifications.Server.StoreLog
       Simplex.Messaging.Notifications.Transport
@@ -71,6 +98,7 @@ library
       Simplex.Messaging.Server.CLI
       Simplex.Messaging.Server.Env.STM
       Simplex.Messaging.Server.Expiration
+      Simplex.Messaging.Server.Main
       Simplex.Messaging.Server.MsgStore
       Simplex.Messaging.Server.MsgStore.STM
       Simplex.Messaging.Server.QueueStore
@@ -79,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
@@ -111,30 +140,32 @@ library
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlite ==2.3.*
+    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
+    , 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.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
-    , sqlite-simple ==0.4.*
+    , 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.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -142,9 +173,10 @@ library
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+    , yaml ==0.11.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable ntf-server
   main-is: Main.hs
@@ -171,31 +203,32 @@ executable ntf-server
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlite ==2.3.*
+    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
+    , 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.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
-    , sqlite-simple ==0.4.*
+    , 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.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -203,9 +236,10 @@ 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
-  default-language: Haskell2010
 
 executable smp-agent
   main-is: Main.hs
@@ -232,31 +266,32 @@ executable smp-agent
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlite ==2.3.*
+    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
+    , 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.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
-    , sqlite-simple ==0.4.*
+    , 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.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -264,9 +299,10 @@ 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
-  default-language: Haskell2010
 
 executable smp-server
   main-is: Main.hs
@@ -293,31 +329,32 @@ executable smp-server
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlite ==2.3.*
+    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
+    , 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.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
-    , sqlite-simple ==0.4.*
+    , 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.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -325,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
-  default-language: Haskell2010
 
-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:
@@ -340,14 +505,21 @@ test-suite smp-server-test
       AgentTests.NotificationTests
       AgentTests.SchemaDump
       AgentTests.SQLiteTests
+      CLITests
+      CoreTests.CryptoTests
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
+      CoreTests.RetryIntervalTests
       CoreTests.VersionRangeTests
+      FileDescriptionTests
       NtfClient
       NtfServerTests
       ServerTests
       SMPAgentClient
       SMPClient
+      XFTPCLI
+      XFTPClient
+      XFTPServerTests
       Paths_simplexmq
   hs-source-dirs:
       tests
@@ -371,26 +543,29 @@ test-suite smp-server-test
     , cryptonite >=0.27 && <0.30
     , cryptostore ==0.2.*
     , data-default ==0.7.*
-    , direct-sqlite ==2.3.*
+    , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random >=1.3 && <1.5
     , hspec ==2.7.*
     , hspec-core ==2.7.*
     , http-types ==0.12.*
-    , http2 ==3.0.*
-    , ini ==0.4.*
+    , http2 ==4.0.*
+    , ini ==0.4.1
     , iso8601-time ==0.1.*
+    , main-tester ==0.2.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , silently ==1.2.*
     , simple-logger ==0.1.*
     , simplexmq
-    , sqlite-simple ==0.4.*
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
     , text ==1.2.*
@@ -398,7 +573,7 @@ test-suite smp-server-test
     , time-compat ==1.9.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -406,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
-  default-language: Haskell2010

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,187 @@
+{-# 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 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.Directory
+import UnliftIO.IO
+
+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}
+
+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 rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
+  (rDhKey, rpDhKey) <- liftIO C.generateKeyPair'
+  sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
+    (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of
+      -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set
+      Just chunkPart -> do
+        let dhSecret = C.dh' sDhKey rpDhKey
+        cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
+        -- timeout download in the same way as upload
+        withExceptT PCEResponseError $
+          receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
+            whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
+      _ -> 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,116 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.FileTransfer.Client.Agent where
+
+import Control.Logger.Simple (logInfo)
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Char8 as B
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Simplex.FileTransfer.Client
+import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
+import Simplex.Messaging.Client.Agent ()
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (tryError)
+import UnliftIO
+
+type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
+
+data XFTPClientAgent = XFTPClientAgent
+  { xftpClients :: TMap XFTPServer XFTPClientVar,
+    config :: XFTPClientAgentConfig
+  }
+
+data XFTPClientAgentConfig = XFTPClientAgentConfig
+  { xftpConfig :: XFTPClientConfig,
+    reconnectInterval :: RetryInterval
+  }
+
+defaultXFTPClientAgentConfig :: XFTPClientAgentConfig
+defaultXFTPClientAgentConfig =
+  XFTPClientAgentConfig
+    { xftpConfig = defaultXFTPClientConfig,
+      reconnectInterval =
+        RetryInterval
+          { initialInterval = 5_000000,
+            increaseAfter = 10_000000,
+            maxInterval = 60_000000
+          }
+    }
+
+data XFTPClientAgentError = XFTPClientAgentError XFTPServer 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)

src/Simplex/FileTransfer/Client/Main.hs

@@ -0,0 +1,561 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.FileTransfer.Client.Main
+  ( xftpClientCLI,
+    prepareChunkSizes,
+  )
+where
+
+import Control.Concurrent.STM (stateTVar)
+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.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 Data.Word (Word32)
+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, 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
+
+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
+  }
+  deriving (Show)
+
+data ReceiveOptions = ReceiveOptions
+  { fileDescription :: FilePath,
+    filePath :: Maybe FilePath,
+    retryCount :: Int,
+    tempPath :: Maybe FilePath
+  }
+  deriving (Show)
+
+data DeleteOptions = DeleteOptions
+  { fileDescription :: FilePath,
+    retryCount :: Int
+  }
+  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
+    receiveP :: Parser ReceiveOptions
+    receiveP =
+      ReceiveOptions
+        <$> fileDescrArg
+        <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)")
+        <*> retryCountP
+        <*> temp
+    deleteP :: Parser DeleteOptions
+    deleteP =
+      DeleteOptions
+        <$> fileDescrArg
+        <*> retryCountP
+    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)")
+    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
+  }
+
+xftpClientCLI :: IO ()
+xftpClientCLI =
+  getCliCommand' cliCommandP clientVersion >>= \case
+    SendFile opts -> runE $ cliSendFile opts
+    ReceiveFile opts -> runE $ cliReceiveFile opts
+    DeleteFile opts -> runE $ cliDeleteFile opts
+    FileDescrInfo opts -> runE $ cliFileDescrInfo opts
+    RandomFile opts -> cliRandomFile opts
+  where
+    clientVersion = "SimpleX XFTP client v" <> xftpClientVersion
+
+runE :: ExceptT CLIError IO () -> IO ()
+runE a =
+  runExceptT a >>= \case
+    Left (CLIError e) -> putStrLn e >> exitFailure
+    _ -> pure ()
+
+-- fileExtra is added to allow header extension in future versions
+data FileHeader = FileHeader
+  { fileName :: String,
+    fileExtra :: Maybe String
+  }
+  deriving (Eq, Show)
+
+instance Encoding FileHeader where
+  smpEncode FileHeader {fileName, fileExtra} = smpEncode (fileName, fileExtra)
+  smpP = do
+    (fileName, fileExtra) <- smpP
+    pure FileHeader {fileName, fileExtra}
+
+cliSendFile :: SendOptions -> ExceptT CLIError IO ()
+cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
+  let (_, fileName) = splitFileName filePath
+  (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 "\nPass file descriptions to the recipient(s):"
+    forM_ fdRcvPaths putStrLn
+    putStrLn "Sender file description:"
+    putStrLn fdSndPath
+  where
+    encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec], Int64)
+    encryptFile fileName = do
+      encPath <- getEncPath tempPath "xftp"
+      key <- liftIO C.randomSbKey
+      nonce <- liftIO C.randomCbNonce
+      fileSize <- fromInteger <$> getFileSize filePath
+      let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
+          fileSize' = fromIntegral (B.length fileHdr) + fileSize
+          chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + 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 = []}
+      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).
+      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
+          (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+          rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
+          chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
+          c <- withRetry retryCount $ getXFTPServerClient a xftpServer
+          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
+          withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
+          uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
+            let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
+          liftIO $ printProgress "Uploaded" uploaded encSize
+          let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
+              replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
+          pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas})
+        getChunkInfo :: SndPublicVerifyKey -> XFTPChunkSpec -> IO FileInfo
+        getChunkInfo sndKey XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
+          withFile chunkPath ReadMode $ \h -> do
+            hSeek h AbsoluteSeek $ fromIntegral chunkOffset
+            digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
+            pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
+        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} =
+  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"
+      path <- decryptFile encSize chunkPaths key nonce
+      forM_ chunks $ acknowledgeFileChunk a
+      whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
+      liftIO $ printNoNewLine $ "File downloaded: " <> path
+      liftIO $ putStrLn "\nFile description can't be used again"
+    downloadFileChunk :: XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
+    downloadFileChunk a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
+      chunkPath <- uniqueCombine encPath $ show chunkNo
+      c <- withRetry retryCount $ getXFTPServerClient a server
+      let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
+      withRetry retryCount $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
+        let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
+      liftIO $ printProgress "Downloaded" downloaded encSize
+      pure (chunkNo, chunkPath)
+    downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas"
+    decryptFile :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
+    decryptFile encSize chunkPaths key nonce = do
+      (authOk, f) <- liftEither . first (CLIError . show) . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (readChunks chunkPaths)
+      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} = do
+  getFileDescription' fileDescription >>= deleteFile
+  where
+    deleteFile :: ValidFileDescription 'FPSender -> ExceptT CLIError IO ()
+    deleteFile (ValidFileDescription FileDescription {chunks}) = do
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
+      forM_ chunks $ deleteFileChunk a
+      liftIO $ putStrLn "File deleted"
+    deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
+    deleteFileChunk a FileChunk {replicas = replica : _} = do
+      let FileChunkReplica {server, replicaId, replicaKey} = replica
+      c <- withRetry retryCount $ getXFTPServerClient a server
+      withRetry retryCount $ deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+    deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
+
+cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
+cliFileDescrInfo InfoOptions {fileDescription} = do
+  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)
+
+withRetry :: Show e => Int -> ExceptT e IO a -> ExceptT CLIError IO a
+withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
+  where
+    withRetry' :: Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
+    withRetry' 0 _ = throwError $ CLIError "internal: no retry attempts"
+    withRetry' 1 a = a
+    withRetry' n a = a `catchError` \_ -> withRetry' (n - 1) a
+
+cliRandomFile :: RandomFileOptions -> IO ()
+cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do
+  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 remove padding when HTTP2 issue is fixed
+      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.sha512Hash <$> LB.readFile filePath
+  when (digest' /= chunkDigest) $ throwError DIGEST

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,11 +13,15 @@
 module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
     AgentConfig (..),
+    AgentDatabase (..),
+    databaseFile,
     InitialAgentServers (..),
+    NetworkConfig (..),
     defaultAgentConfig,
     defaultReconnectInterval,
     Env (..),
     newSMPAgentEnv,
+    createAgentStore,
     NtfSupervisor (..),
     NtfSupervisorCommand (..),
   )
@@ -27,22 +32,26 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map (Map)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer)
+import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
+import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
@@ -52,22 +61,36 @@ import UnliftIO.STM
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServer,
-    ntf :: [NtfServer]
+  { smp :: Map UserId (NonEmpty SMPServerWithAuth),
+    ntf :: [NtfServer],
+    netCfg :: NetworkConfig
   }
 
+data AgentDatabase
+  = AgentDB SQLiteStore
+  | AgentDBFile {dbFile :: FilePath, dbKey :: String}
+
+databaseFile :: AgentDatabase -> FilePath
+databaseFile = \case
+  AgentDB SQLiteStore {dbFilePath} -> dbFilePath
+  AgentDBFile {dbFile} -> dbFile
+
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
     cmdSignAlg :: C.SignAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
-    dbFile :: FilePath,
+    database :: AgentDatabase,
     yesToMigrations :: Bool,
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
+    messageRetryInterval :: RetryInterval2,
+    messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
-    resubscriptionConcurrency :: Int,
+    initialCleanupDelay :: Int,
+    cleanupInterval :: Int,
+    deleteErrorCount :: Int,
     ntfCron :: Word16,
     ntfWorkerDelay :: Int,
     ntfSMPWorkerDelay :: Int,
@@ -76,19 +99,39 @@ data AgentConfig = AgentConfig
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
-    smpAgentVersion :: Version,
-    smpAgentVRange :: VersionRange
+    e2eEncryptVRange :: VersionRange,
+    smpAgentVRange :: VersionRange,
+    smpClientVRange :: VersionRange,
+    initialClientId :: Int
   }
 
 defaultReconnectInterval :: RetryInterval
 defaultReconnectInterval =
   RetryInterval
-    { initialInterval = second,
-      increaseAfter = 10 * second,
-      maxInterval = 10 * second
+    { initialInterval = 2_000000,
+      increaseAfter = 10_000000,
+      maxInterval = 180_000000
+    }
+
+defaultMessageRetryInterval :: RetryInterval2
+defaultMessageRetryInterval =
+  RetryInterval2
+    { riFast =
+        RetryInterval
+          { initialInterval = 1_000000,
+            increaseAfter = 10_000000,
+            maxInterval = 60_000000
+          },
+      riSlow =
+        -- 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 = 60_000000,
+            increaseAfter = 60_000000,
+            maxInterval = 1200_000000 -- 20min
+          }
     }
-  where
-    second = 1_000_000
 
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
@@ -97,13 +140,17 @@ defaultAgentConfig =
       cmdSignAlg = C.SignAlg C.SEd448,
       connIdBytes = 12,
       tbqSize = 64,
-      dbFile = "smp-agent.db",
+      database = AgentDBFile {dbFile = "smp-agent.db", dbKey = ""},
       yesToMigrations = False,
-      smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
+      smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
       reconnectInterval = defaultReconnectInterval,
+      messageRetryInterval = defaultMessageRetryInterval,
+      messageTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
-      resubscriptionConcurrency = 16,
+      initialCleanupDelay = 30 * 1000000, -- 30 seconds
+      cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
+      deleteErrorCount = 10,
       ntfCron = 20, -- minutes
       ntfWorkerDelay = 100000, -- microseconds
       ntfSMPWorkerDelay = 500000, -- microseconds
@@ -114,8 +161,10 @@ defaultAgentConfig =
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
       privateKeyFile = "/etc/opt/simplex-agent/agent.key",
       certificateFile = "/etc/opt/simplex-agent/agent.crt",
-      smpAgentVersion = currentSMPAgentVersion,
-      smpAgentVRange = supportedSMPAgentVRange
+      e2eEncryptVRange = supportedE2EEncryptVRange,
+      smpAgentVRange = supportedSMPAgentVRange,
+      smpClientVRange = supportedSMPClientVRange,
+      initialClientId = 0
     }
 
 data Env = Env
@@ -128,14 +177,19 @@ data Env = Env
   }
 
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
-newSMPAgentEnv config@AgentConfig {dbFile, yesToMigrations} = do
+newSMPAgentEnv config@AgentConfig {database, yesToMigrations, initialClientId} = do
   idsDrg <- newTVarIO =<< drgNew
-  store <- liftIO $ createSQLiteStore dbFile Migrations.app yesToMigrations
-  clientCounter <- newTVarIO 0
+  store <- case database of
+    AgentDB st -> pure st
+    AgentDBFile {dbFile, dbKey} -> liftIO $ createAgentStore dbFile dbKey yesToMigrations
+  clientCounter <- newTVarIO initialClientId
   randomServer <- newTVarIO =<< liftIO newStdGen
   ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
   return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
 
+createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore
+createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app
+
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
     ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),

src/Simplex/Messaging/Agent/Lock.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Agent.Lock where
+
+import Control.Monad (void)
+import Control.Monad.IO.Unlift
+import Data.Functor (($>))
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM
+
+type Lock = TMVar String
+
+createLock :: STM Lock
+createLock = newEmptyTMVar
+{-# INLINE createLock #-}
+
+withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a
+withLock lock name =
+  E.bracket_
+    (atomically $ putTMVar lock name)
+    (void . atomically $ takeTMVar lock)
+
+withGetLock :: MonadUnliftIO m => STM Lock -> String -> m a -> m a
+withGetLock getLock name a =
+  E.bracket
+    (atomically $ getLock >>= \l -> putTMVar l name $> l)
+    (atomically . takeTMVar)
+    (const a)

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
     nsUpdateToken,
     nsRemoveNtfToken,
     sendNtfSubCommand,
+    instantNotifications,
     closeNtfSupervisor,
     getNtfServer,
   )
@@ -54,7 +55,7 @@ runNtfSupervisor c = do
   ns <- asks ntfSupervisor
   forever $ do
     cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
-    handleError connId . agentOperationBracket c AONtfNetwork $
+    handleError connId . agentOperationBracket c AONtfNetwork waitUntilActive $
       runExceptT (processNtfSub c cmd) >>= \case
         Left e -> notifyErr connId e
         Right _ -> return ()
@@ -72,7 +73,7 @@ processNtfSub c (connId, cmd) = do
     NSCCreate -> do
       (a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
         a <- liftIO $ getNtfSubscription db connId
-        q <- ExceptT $ getRcvQueue db connId
+        q <- ExceptT $ getPrimaryRcvQueue db connId
         pure (a, q)
       logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
       case a of
@@ -81,60 +82,62 @@ processNtfSub c (connId, cmd) = do
             case clientNtfCreds of
               Just ClientNtfCreds {notifierId} -> do
                 let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
-                ts <- liftIO getCurrentTime
-                withStore' c $ \db -> createNtfSubscription db newSub (NtfSubNTFAction NSACreate) ts
+                withStore c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
                 addNtfNTFWorker ntfServer
               Nothing -> do
                 let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
-                ts <- liftIO getCurrentTime
-                withStore' c $ \db -> createNtfSubscription db newSub (NtfSubSMPAction NSASmpKey) ts
+                withStore c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
                 addNtfSMPWorker smpServer
-        (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer}, action_)) -> do
-          case action_ of
-            -- action was set to NULL after worker internal error
-            Nothing -> resetSubscription
-            Just (action, _)
-              -- subscription was marked for deletion / is being deleted
-              | isDeleteNtfSubAction action -> do
-                if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
-                  then resetSubscription
-                  else withNtfServer c $ \ntfServer -> do
-                    ts <- liftIO getCurrentTime
-                    withStore' c $ \db ->
-                      supervisorUpdateNtfSubscription db sub {ntfServer} (NtfSubNTFAction NSACreate) ts
-                    addNtfNTFWorker ntfServer
-              | otherwise -> case action of
-                NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
-                NtfSubSMPAction _ -> addNtfSMPWorker smpServer
+        (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
+          case (clientNtfCreds, ntfQueueId) of
+            (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
+              | sameSrvAddr smpServer smpServer' && notifierId == ntfQueueId' -> create
+              | otherwise -> rotate
+            (Nothing, Nothing) -> create
+            _ -> rotate
           where
+            create :: m ()
+            create = case action_ of
+              -- action was set to NULL after worker internal error
+              Nothing -> resetSubscription
+              Just (action, _)
+                -- subscription was marked for deletion / is being deleted
+                | isDeleteNtfSubAction action -> do
+                  if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
+                    then resetSubscription
+                    else withNtfServer c $ \ntfServer -> do
+                      withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
+                      addNtfNTFWorker ntfServer
+                | otherwise -> case action of
+                  NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
+                  NtfSubSMPAction _ -> addNtfSMPWorker smpServer
+            rotate :: m ()
+            rotate = do
+              withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
+              addNtfNTFWorker subNtfServer
             resetSubscription :: m ()
             resetSubscription =
               withNtfServer c $ \ntfServer -> do
-                ts <- liftIO getCurrentTime
-                withStore' c $ \db ->
-                  supervisorUpdateNtfSubscription db sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
+                let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
+                withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
                 addNtfSMPWorker smpServer
     NSCDelete -> do
       sub_ <- withStore' c $ \db -> do
-        ts <- liftIO getCurrentTime
-        supervisorUpdateNtfSubAction db connId (NtfSubNTFAction NSADelete) ts
+        supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
         getNtfSubscription db connId
       logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
       case sub_ of
         (Just (NtfSubscription {ntfServer}, _)) -> addNtfNTFWorker ntfServer
         _ -> pure () -- err "NSCDelete - no subscription"
     NSCSmpDelete -> do
-      withStore' c (`getRcvQueue` connId) >>= \case
+      withStore' c (`getPrimaryRcvQueue` connId) >>= \case
         Right rq@RcvQueue {server = smpServer} -> do
           logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
-          ts <- liftIO getCurrentTime
-          withStore' c $ \db -> supervisorUpdateNtfSubAction db connId (NtfSubSMPAction NSASmpDelete) ts
+          withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
           addNtfSMPWorker smpServer
         _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    NSCNtfWorker ntfServer ->
-      addNtfNTFWorker ntfServer
-    NSCNtfSMPWorker smpServer ->
-      addNtfSMPWorker smpServer
+    NSCNtfWorker ntfServer -> addNtfNTFWorker ntfServer
+    NSCNtfSMPWorker smpServer -> addNtfSMPWorker smpServer
   where
     addNtfNTFWorker = addWorker ntfWorkers runNtfWorker
     addNtfSMPWorker = addWorker ntfSMPWorkers runNtfSMPWorker
@@ -161,7 +164,7 @@ runNtfWorker c srv doWork = do
   delay <- asks $ ntfWorkerDelay . config
   forever $ do
     void . atomically $ readTMVar doWork
-    agentOperationBracket c AONtfNetwork runNtfOperation
+    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
     threadDelay delay
   where
     runNtfOperation :: m ()
@@ -184,11 +187,11 @@ runNtfWorker c srv doWork = do
           NSACreate ->
             getNtfToken >>= \case
               Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                RcvQueue {clientNtfCreds} <- withStore c (`getRcvQueue` connId)
+                RcvQueue {clientNtfCreds} <- withStore c (`getPrimaryRcvQueue` connId)
                 case clientNtfCreds of
                   Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
                     nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
-                    -- TODO smaller retry until Active, less frequently (daily?) once Active
+                    -- possible improvement: smaller retry until Active, less frequently (daily?) once Active
                     let actionTs' = addUTCTime 30 ts
                     withStore' c $ \db ->
                       updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs'
@@ -213,16 +216,25 @@ runNtfWorker c srv doWork = do
               _ -> workerInternalError c connId "NSACheck - no active token"
           NSADelete -> case ntfSubId of
             Just nSubId ->
-              (getNtfToken >>= \tkn -> forM_ tkn $ agentNtfDeleteSubscription c nSubId)
-                `E.finally` carryOnWithDeletion
-            Nothing -> carryOnWithDeletion
+              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
+                `E.finally` continueDeletion
+            _ -> continueDeletion
             where
-              carryOnWithDeletion :: m ()
-              carryOnWithDeletion = do
-                withStore' c $ \db ->
-                  updateNtfSubscription db sub {ntfSubId = Nothing, ntfSubStatus = NASOff} (NtfSubSMPAction NSASmpDelete) ts
+              continueDeletion = do
+                let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
+                withStore' c $ \db -> updateNtfSubscription db sub' (NtfSubSMPAction NSASmpDelete) ts
                 ns <- asks ntfSupervisor
                 atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+          NSARotate -> case ntfSubId of
+            Just nSubId ->
+              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
+                `E.finally` deleteCreate
+            _ -> deleteCreate
+            where
+              deleteCreate = do
+                withStore' c $ \db -> deleteNtfSubscription db connId
+                ns <- asks ntfSupervisor
+                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
       where
         updateSubNextCheck ts toStatus = do
           checkInterval <- asks $ ntfSubCheckInterval . config
@@ -237,7 +249,7 @@ runNtfSMPWorker c srv doWork = do
   delay <- asks $ ntfSMPWorkerDelay . config
   forever $ do
     void . atomically $ readTMVar doWork
-    agentOperationBracket c AONtfNetwork runNtfSMPOperation
+    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
     threadDelay delay
   where
     runNtfSMPOperation = do
@@ -259,7 +271,7 @@ runNtfSMPWorker c srv doWork = do
           NSASmpKey ->
             getNtfToken >>= \case
               Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                rq <- withStore c (`getRcvQueue` connId)
+                rq <- withStore c (`getPrimaryRcvQueue` connId)
                 C.SignAlg a <- asks (cmdSignAlg . config)
                 (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
                 (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair'
@@ -274,8 +286,8 @@ runNtfSMPWorker c srv doWork = do
           NSASmpDelete -> do
             rq_ <- withStore' c $ \db -> do
               setRcvQueueNtfCreds db connId Nothing
-              getRcvQueue db connId
-            forM_ rq_ $ \rq -> disableQueueNotifications c rq
+              getPrimaryRcvQueue db connId
+            mapM_ (disableQueueNotifications c) rq_
             withStore' c $ \db -> deleteNtfSubscription db connId
 
 rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool
@@ -298,12 +310,13 @@ retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -
 retryOnError c name loop done e = do
   logError $ name <> " error: " <> tshow e
   case e of
-    BROKER NETWORK -> retryLoop
-    BROKER TIMEOUT -> retryLoop
+    BROKER _ NETWORK -> retryLoop
+    BROKER _ TIMEOUT -> retryLoop
     _ -> done e
   where
     retryLoop = do
       atomically $ endAgentOperation c AONtfNetwork
+      atomically $ throwWhenInactive c
       atomically $ beginAgentOperation c AONtfNetwork
       loop
 
@@ -327,13 +340,14 @@ nsRemoveNtfToken :: NtfSupervisor -> STM ()
 nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
 
 sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
-sendNtfSubCommand ns cmd =
-  readTVar (ntfTkn ns)
-    >>= mapM_
-      ( \NtfToken {ntfTknStatus, ntfMode} ->
-          when (ntfTknStatus == NTActive && ntfMode == NMInstant) $
-            writeTBQueue (ntfSubQ ns) cmd
-      )
+sendNtfSubCommand ns cmd = do
+  tkn <- readTVar (ntfTkn ns)
+  when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
+
+instantNotifications :: Maybe NtfToken -> Bool
+instantNotifications = \case
+  Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
+  _ -> False
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()
 closeNtfSupervisor ns = do
@@ -343,7 +357,7 @@ closeNtfSupervisor ns = do
 cancelNtfWorkers_ :: TMap (ProtocolServer s) (TMVar (), Async ()) -> IO ()
 cancelNtfWorkers_ wsVar = do
   ws <- atomically $ stateTVar wsVar (,M.empty)
-  forM_ ws $ uninterruptibleCancel . snd
+  mapM_ (uninterruptibleCancel . snd) ws
 
 getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer)
 getNtfServer c = do

src/Simplex/Messaging/Agent/QueryString.hs

@@ -24,7 +24,16 @@ instance StrEncoding QueryStringParams where
   strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
 
 queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a
-queryParam name (QSP _ q) =
-  case find ((== name) . fst) q of
-    Just (_, p) -> either fail pure $ parseAll strP p
+queryParam name q =
+  case queryParamStr name q of
+    Just p -> either fail pure $ parseAll strP p
     _ -> fail $ "no qs param " <> B.unpack name
+
+queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
+queryParam_ name q =
+  case queryParamStr name q of
+    Just p -> either fail pure $ parseAll strP p
+    _ -> pure Nothing
+
+queryParamStr :: ByteString -> QueryStringParams -> Maybe ByteString
+queryParamStr name (QSP _ q) = snd <$> find ((== name) . fst) q

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -1,10 +1,21 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Simplex.Messaging.Agent.RetryInterval where
+module Simplex.Messaging.Agent.RetryInterval
+  ( RetryInterval (..),
+    RetryInterval2 (..),
+    RetryIntervalMode (..),
+    withRetryInterval,
+    withRetryLock2,
+  )
+where
 
-import Control.Concurrent (threadDelay)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Simplex.Messaging.Util (whenM)
+import UnliftIO.STM
 
 data RetryInterval = RetryInterval
   { initialInterval :: Int,
@@ -12,17 +23,51 @@ data RetryInterval = RetryInterval
     maxInterval :: Int
   }
 
+data RetryInterval2 = RetryInterval2
+  { riSlow :: RetryInterval,
+    riFast :: RetryInterval
+  }
+
+data RetryIntervalMode = RISlow | RIFast
+  deriving (Eq)
+
 withRetryInterval :: forall m. MonadIO m => RetryInterval -> (m () -> m ()) -> m ()
-withRetryInterval RetryInterval {initialInterval, increaseAfter, maxInterval} action =
-  callAction 0 initialInterval
+withRetryInterval ri action = callAction 0 $ initialInterval ri
   where
     callAction :: Int -> Int -> m ()
-    callAction elapsedTime delay = action loop
+    callAction elapsed delay = action loop
       where
         loop = do
-          let newDelay =
-                if elapsedTime < increaseAfter || delay == maxInterval
-                  then delay
-                  else min (delay * 3 `div` 2) maxInterval
           liftIO $ threadDelay delay
-          callAction (elapsedTime + delay) newDelay
+          let elapsed' = elapsed + delay
+          callAction elapsed' $ nextDelay elapsed' delay ri
+
+-- This function allows action to toggle between slow and fast retry intervals.
+withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> ((RetryIntervalMode -> m ()) -> m ()) -> m ()
+withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
+  callAction (0, initialInterval riSlow) (0, initialInterval riFast)
+  where
+    callAction :: (Int, Int) -> (Int, Int) -> m ()
+    callAction slow fast = action loop
+      where
+        loop = \case
+          RISlow -> run slow riSlow (`callAction` fast)
+          RIFast -> run fast riFast (callAction slow)
+        run (elapsed, delay) ri call = do
+          wait delay
+          let elapsed' = elapsed + delay
+          call (elapsed', nextDelay elapsed' delay ri)
+        wait delay = do
+          waiting <- newTVarIO True
+          _ <- liftIO . forkIO $ do
+            threadDelay delay
+            atomically $ whenM (readTVar waiting) $ void $ tryPutTMVar lock ()
+          atomically $ do
+            takeTMVar lock
+            writeTVar waiting False
+
+nextDelay :: Int -> Int -> RetryInterval -> Int
+nextDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
+  if elapsed < increaseAfter || delay == maxInterval
+    then delay
+    else min (delay * 3 `div` 2) maxInterval

src/Simplex/Messaging/Agent/Server.hs

@@ -48,7 +48,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
     smpAgent _ = do
       -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
       tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-      runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
+      runTransportServer started tcpPort tlsServerParams True $ \(h :: c) -> do
         liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
         c <- getAgentClient initServers
         logConnection c True

src/Simplex/Messaging/Agent/Store.hs

@@ -3,21 +3,30 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Store where
 
 import Control.Exception (Exception)
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Kind (Type)
+import Data.List (find)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Time (UTCTime)
 import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgFlags,
@@ -25,19 +34,23 @@ import Simplex.Messaging.Protocol
     NotifierId,
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
+    QueueId,
     RcvDhSecret,
     RcvNtfDhSecret,
     RcvPrivateSignKey,
     SndPrivateSignKey,
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Util ((<$?>))
 import Simplex.Messaging.Version
 
 -- * Queue types
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
 data RcvQueue = RcvQueue
-  { server :: SMPServer,
+  { userId :: UserId,
+    connId :: ConnId,
+    server :: SMPServer,
     -- | recipient queue ID
     rcvId :: SMP.RecipientId,
     -- | key used by the recipient to sign transmissions
@@ -49,11 +62,20 @@ data RcvQueue = RcvQueue
     -- | public sender's DH key and agreed shared DH secret for simple per-queue e2e
     e2eDhSecret :: Maybe C.DhSecretX25519,
     -- | sender queue ID
-    sndId :: Maybe SMP.SenderId,
+    sndId :: SMP.SenderId,
     -- | queue status
     status :: QueueStatus,
+    -- | database queue ID (within connection), can be Nothing for old queues
+    dbQueueId :: Int64,
+    -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
+    primary :: Bool,
+    -- | database queue ID to replace, Nothing if this queue is not replacing another, `Just Nothing` is used for replacing old queues
+    dbReplaceQueueId :: Maybe Int64,
+    -- | SMP client version
+    smpClientVersion :: Version,
     -- | credentials used in context of notifications
-    clientNtfCreds :: Maybe ClientNtfCreds
+    clientNtfCreds :: Maybe ClientNtfCreds,
+    deleteErrors :: Int
   }
   deriving (Eq, Show)
 
@@ -70,7 +92,9 @@ data ClientNtfCreds = ClientNtfCreds
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
 data SndQueue = SndQueue
-  { server :: SMPServer,
+  { userId :: UserId,
+    connId :: ConnId,
+    server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
     -- | key pair used by the sender to sign transmissions
@@ -81,14 +105,80 @@ data SndQueue = SndQueue
     -- | shared DH secret agreed for simple per-queue e2e encryption
     e2eDhSecret :: C.DhSecretX25519,
     -- | queue status
-    status :: QueueStatus
+    status :: QueueStatus,
+    -- | database queue ID (within connection), can be Nothing for old queues
+    dbQueueId :: Int64,
+    -- | True for a primary or a next primary queue of the connection (next if dbReplaceQueueId is set)
+    primary :: Bool,
+    -- | ID of the queue this one is replacing
+    dbReplaceQueueId :: Maybe Int64,
+    -- | SMP client version
+    smpClientVersion :: Version
   }
   deriving (Eq, Show)
 
+instance SMPQueue RcvQueue where
+  qServer RcvQueue {server} = server
+  {-# INLINE qServer #-}
+  qAddress RcvQueue {server, rcvId} = (server, rcvId)
+  {-# INLINE qAddress #-}
+  sameQueue addr q = sameQAddress addr (qAddress q)
+  {-# INLINE sameQueue #-}
+
+instance SMPQueue SndQueue where
+  qServer SndQueue {server} = server
+  {-# INLINE qServer #-}
+  qAddress SndQueue {server, sndId} = (server, sndId)
+  {-# INLINE qAddress #-}
+  sameQueue addr q = sameQAddress addr (qAddress q)
+  {-# INLINE sameQueue #-}
+
+findQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe q
+findQ = find . sameQueue
+{-# INLINE findQ #-}
+
+removeQ :: SMPQueue q => (SMPServer, SMP.QueueId) -> NonEmpty q -> Maybe (q, [q])
+removeQ = removeQP . sameQueue
+{-# INLINE removeQ #-}
+
+removeQP :: (q -> Bool) -> NonEmpty q -> Maybe (q, [q])
+removeQP p qs = case L.break p qs of
+  (_, []) -> Nothing
+  (qs1, q : qs2) -> Just (q, qs1 <> qs2)
+
+sndAddress :: RcvQueue -> (SMPServer, SMP.SenderId)
+sndAddress RcvQueue {server, sndId} = (server, sndId)
+{-# INLINE sndAddress #-}
+
+findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
+findRQ sAddr = find $ sameQAddress sAddr . sndAddress
+{-# INLINE findRQ #-}
+
+class SMPQueue q => SMPQueueRec q where
+  qUserId :: q -> UserId
+  qConnId :: q -> ConnId
+  queueId :: q -> QueueId
+
+instance SMPQueueRec RcvQueue where
+  qUserId = userId
+  {-# INLINE qUserId #-}
+  qConnId = connId
+  {-# INLINE qConnId #-}
+  queueId = rcvId
+  {-# INLINE queueId #-}
+
+instance SMPQueueRec SndQueue where
+  qUserId = userId
+  {-# INLINE qUserId #-}
+  qConnId = connId
+  {-# INLINE qConnId #-}
+  queueId = sndId
+  {-# INLINE queueId #-}
+
 -- * Connection types
 
 -- | Type of a connection.
-data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
+data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 
 -- | Connection of a specific type.
 --
@@ -101,22 +191,33 @@ data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 -- - DuplexConnection is a connection that has both receive and send queues set up,
 --   typically created by upgrading a receive or a send connection with a missing queue.
 data Connection (d :: ConnType) where
+  NewConnection :: ConnData -> Connection CNew
   RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
   SndConnection :: ConnData -> SndQueue -> Connection CSnd
-  DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex
+  DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
   ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
 deriving instance Eq (Connection d)
 
 deriving instance Show (Connection d)
 
+connData :: Connection d -> ConnData
+connData = \case
+  NewConnection cData -> cData
+  RcvConnection cData _ -> cData
+  SndConnection cData _ -> cData
+  DuplexConnection cData _ _ -> cData
+  ContactConnection cData _ -> cData
+
 data SConnType :: ConnType -> Type where
+  SCNew :: SConnType CNew
   SCRcv :: SConnType CRcv
   SCSnd :: SConnType CSnd
   SCDuplex :: SConnType CDuplex
   SCContact :: SConnType CContact
 
 connType :: SConnType c -> ConnType
+connType SCNew = CNew
 connType SCRcv = CRcv
 connType SCSnd = CSnd
 connType SCDuplex = CDuplex
@@ -146,11 +247,135 @@ deriving instance Show SomeConn
 
 data ConnData = ConnData
   { connId :: ConnId,
+    userId :: UserId,
     connAgentVersion :: Version,
-    duplexHandshake :: Maybe Bool -- added in agent protocol v2
+    enableNtfs :: Bool,
+    duplexHandshake :: Maybe Bool, -- added in agent protocol v2
+    deleted :: Bool
   }
   deriving (Eq, Show)
 
+data PendingCommand = PendingCommand
+  { corrId :: ACorrId,
+    userId :: UserId,
+    connId :: ConnId,
+    command :: AgentCommand
+  }
+
+data AgentCmdType = ACClient | ACInternal
+
+type UserId = Int64
+
+instance StrEncoding AgentCmdType where
+  strEncode = \case
+    ACClient -> "CLIENT"
+    ACInternal -> "INTERNAL"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "CLIENT" -> pure ACClient
+      "INTERNAL" -> pure ACInternal
+      _ -> fail "bad AgentCmdType"
+
+data AgentCommand
+  = AClientCommand (ACommand 'Client)
+  | AInternalCommand InternalCommand
+
+instance StrEncoding AgentCommand where
+  strEncode = \case
+    AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
+    AInternalCommand cmd -> strEncode (ACInternal, cmd)
+  strP =
+    strP_ >>= \case
+      ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP)
+      ACInternal -> AInternalCommand <$> strP
+
+data AgentCommandTag
+  = AClientCommandTag (ACommandTag 'Client)
+  | AInternalCommandTag InternalCommandTag
+  deriving (Show)
+
+instance StrEncoding AgentCommandTag where
+  strEncode = \case
+    AClientCommandTag t -> strEncode (ACClient, t)
+    AInternalCommandTag t -> strEncode (ACInternal, t)
+  strP =
+    strP_ >>= \case
+      ACClient -> AClientCommandTag <$> strP
+      ACInternal -> AInternalCommandTag <$> strP
+
+data InternalCommand
+  = ICAck SMP.RecipientId MsgId
+  | ICAckDel SMP.RecipientId MsgId InternalId
+  | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
+  | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
+  | ICDeleteConn
+  | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
+  | ICQDelete SMP.RecipientId
+
+data InternalCommandTag
+  = ICAck_
+  | ICAckDel_
+  | ICAllowSecure_
+  | ICDuplexSecure_
+  | ICDeleteConn_
+  | ICQSecure_
+  | ICQDelete_
+  deriving (Show)
+
+instance StrEncoding InternalCommand where
+  strEncode = \case
+    ICAck rId srvMsgId -> strEncode (ICAck_, rId, srvMsgId)
+    ICAckDel rId srvMsgId mId -> strEncode (ICAckDel_, rId, srvMsgId, mId)
+    ICAllowSecure rId sndKey -> strEncode (ICAllowSecure_, rId, sndKey)
+    ICDuplexSecure rId sndKey -> strEncode (ICDuplexSecure_, rId, sndKey)
+    ICDeleteConn -> strEncode ICDeleteConn_
+    ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
+    ICQDelete rId -> strEncode (ICQDelete_, rId)
+  strP =
+    strP >>= \case
+      ICAck_ -> ICAck <$> _strP <*> _strP
+      ICAckDel_ -> ICAckDel <$> _strP <*> _strP <*> _strP
+      ICAllowSecure_ -> ICAllowSecure <$> _strP <*> _strP
+      ICDuplexSecure_ -> ICDuplexSecure <$> _strP <*> _strP
+      ICDeleteConn_ -> pure ICDeleteConn
+      ICQSecure_ -> ICQSecure <$> _strP <*> _strP
+      ICQDelete_ -> ICQDelete <$> _strP
+
+instance StrEncoding InternalCommandTag where
+  strEncode = \case
+    ICAck_ -> "ACK"
+    ICAckDel_ -> "ACK_DEL"
+    ICAllowSecure_ -> "ALLOW_SECURE"
+    ICDuplexSecure_ -> "DUPLEX_SECURE"
+    ICDeleteConn_ -> "DELETE_CONN"
+    ICQSecure_ -> "QSECURE"
+    ICQDelete_ -> "QDELETE"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "ACK" -> pure ICAck_
+      "ACK_DEL" -> pure ICAckDel_
+      "ALLOW_SECURE" -> pure ICAllowSecure_
+      "DUPLEX_SECURE" -> pure ICDuplexSecure_
+      "DELETE_CONN" -> pure ICDeleteConn_
+      "QSECURE" -> pure ICQSecure_
+      "QDELETE" -> pure ICQDelete_
+      _ -> fail "bad InternalCommandTag"
+
+agentCommandTag :: AgentCommand -> AgentCommandTag
+agentCommandTag = \case
+  AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
+  AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
+
+internalCmdTag :: InternalCommand -> InternalCommandTag
+internalCmdTag = \case
+  ICAck {} -> ICAck_
+  ICAckDel {} -> ICAckDel_
+  ICAllowSecure {} -> ICAllowSecure_
+  ICDuplexSecure {} -> ICDuplexSecure_
+  ICDeleteConn -> ICDeleteConn_
+  ICQSecure {} -> ICQSecure_
+  ICQDelete _ -> ICQDelete_
+
 -- * Confirmation types
 
 data NewConfirmation = NewConfirmation
@@ -265,8 +490,14 @@ data MsgBase = MsgBase
 
 newtype InternalId = InternalId {unId :: Int64} deriving (Eq, Show)
 
+instance StrEncoding InternalId where
+  strEncode = strEncode . unId
+  strP = InternalId <$> strP
+
 type InternalTs = UTCTime
 
+type AsyncCmdId = Int64
+
 -- * Store errors
 
 -- | Agent store error.
@@ -275,8 +506,12 @@ data StoreError
     SEInternal ByteString
   | -- | Failed to generate unique random ID
     SEUniqueID
+  | -- | User ID not found
+    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.
@@ -288,6 +523,8 @@ data StoreError
     SEInvitationNotFound
   | -- | Message not found
     SEMsgNotFound
+  | -- | Command not found
+    SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
     -- as we always know what it should be at any stage of the protocol,
     -- and in case it does not match use this error.
@@ -296,8 +533,6 @@ data StoreError
     SERatchetNotFound
   | -- | connection does not have associated x3dh keys
     SEX3dhKeysNotFound
-  | -- | Used in `getMsg` that is not implemented/used. TODO remove.
-    SENotImplemented
   | -- | Used to wrap agent errors inside store operations to avoid race conditions
     SEAgentError AgentErrorType
   deriving (Eq, Show, Exception)

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -15,20 +16,33 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
   )
 where
 
-import Control.Monad (forM_)
-import Data.Function (on)
-import Data.List (intercalate, sortBy)
+import Control.Monad (forM_, when)
+import Data.List (intercalate, sortOn)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Map as M
 import Data.Text (Text)
+import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (getCurrentTime)
 import Database.SQLite.Simple (Connection, Only (..), Query (..))
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
+import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
+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)
 
 data Migration = Migration {name :: String, up :: Text}
   deriving (Show)
@@ -39,12 +53,20 @@ schemaMigrations =
     ("20220301_snd_queue_keys", m20220301_snd_queue_keys),
     ("20220322_notifications", m20220322_notifications),
     ("20220607_v2", m20220608_v2),
-    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode)
+    ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode),
+    ("m20220811_onion_hosts", m20220811_onion_hosts),
+    ("m20220817_connection_ntfs", m20220817_connection_ntfs),
+    ("m20220905_commands", m20220905_commands),
+    ("m20220915_connection_queues", m20220915_connection_queues),
+    ("m20230110_users", m20230110_users),
+    ("m20230117_fkey_indexes", m20230117_fkey_indexes),
+    ("m20230120_delete_errors", m20230120_delete_errors),
+    ("m20230217_server_key_hash", m20230217_server_key_hash)
   ]
 
 -- | The list of migrations in ascending order by date
 app :: [Migration]
-app = sortBy (compare `on` name) $ map migration schemaMigrations
+app = sortOn name $ map migration schemaMigrations
   where
     migration (name, query) = Migration {name = name, up = fromQuery query}
 
@@ -54,11 +76,16 @@ get conn migrations =
     <$> DB.query_ conn "SELECT name FROM migrations ORDER BY name ASC;"
 
 run :: Connection -> [Migration] -> IO ()
-run conn ms = DB.withImmediateTransaction conn . forM_ ms $
-  \Migration {name, up} -> insert name >> execSQL up
+run conn ms = forM_ ms $ \Migration {name, up} -> do
+  when (name == "m20220811_onion_hosts") updateServers
+  DB.withImmediateTransaction conn $ insert name >> execSQL up
   where
     insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
     execSQL = SQLite3.exec $ DB.connectionHandle conn
+    updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
+      DB.withImmediateTransaction conn $
+        let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
+         in DB.execute conn "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
 
 initialize :: Connection -> IO ()
 initialize conn =

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

@@ -107,8 +107,8 @@ CREATE TABLE snd_messages (
 CREATE TABLE conn_confirmations (
   confirmation_id BLOB NOT NULL PRIMARY KEY,
   conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?
-  sender_key BLOB NOT NULL, -- TODO per-queue key. Split?
+  e2e_snd_pub_key BLOB NOT NULL,
+  sender_key BLOB NOT NULL,
   ratchet_state BLOB NOT NULL,
   sender_conn_info BLOB NOT NULL,
   accepted INTEGER NOT NULL,

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

@@ -0,0 +1,16 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220811_onion_hosts :: Query
+m20220811_onion_hosts =
+  [sql|
+ALTER TABLE conn_confirmations ADD COLUMN smp_client_version INTEGER;
+
+UPDATE ntf_servers
+SET ntf_host = 'ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion'
+WHERE ntf_host = 'ntf2.simplex.im';
+|]

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

@@ -0,0 +1,12 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220817_connection_ntfs :: Query
+m20220817_connection_ntfs =
+  [sql|
+ALTER TABLE connections ADD COLUMN enable_ntfs INTEGER;
+|]

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

@@ -0,0 +1,23 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220905_commands :: Query
+m20220905_commands =
+  [sql|
+CREATE TABLE commands (
+  command_id INTEGER PRIMARY KEY,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  host TEXT,
+  port TEXT,
+  corr_id BLOB NOT NULL,
+  command_tag BLOB NOT NULL,
+  command BLOB NOT NULL,
+  agent_version INTEGER NOT NULL DEFAULT 1,
+  FOREIGN KEY (host, port) REFERENCES servers
+    ON DELETE RESTRICT ON UPDATE CASCADE
+);
+|]

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

@@ -0,0 +1,52 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220915_connection_queues :: Query
+m20220915_connection_queues =
+  [sql|
+PRAGMA ignore_check_constraints=ON;
+
+-- rcv_queues
+ALTER TABLE rcv_queues ADD COLUMN rcv_queue_id INTEGER CHECK (rcv_queue_id NOT NULL);
+UPDATE rcv_queues SET rcv_queue_id = 1;
+CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues (conn_id, rcv_queue_id);
+
+ALTER TABLE rcv_queues ADD COLUMN rcv_primary INTEGER CHECK (rcv_primary NOT NULL);
+UPDATE rcv_queues SET rcv_primary = 1;
+
+ALTER TABLE rcv_queues ADD COLUMN replace_rcv_queue_id INTEGER NULL;
+
+-- snd_queues
+ALTER TABLE snd_queues ADD COLUMN snd_queue_id INTEGER CHECK (snd_queue_id NOT NULL);
+UPDATE snd_queues SET snd_queue_id = 1;
+CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues (conn_id, snd_queue_id);
+
+ALTER TABLE snd_queues ADD COLUMN snd_primary INTEGER CHECK (snd_primary NOT NULL);
+UPDATE snd_queues SET snd_primary = 1;
+
+ALTER TABLE snd_queues ADD COLUMN replace_snd_queue_id INTEGER NULL;
+
+-- connections
+ALTER TABLE connections ADD COLUMN deleted INTEGER DEFAULT 0 CHECK (deleted NOT NULL);
+UPDATE connections SET deleted = 0;
+
+-- messages
+CREATE TABLE snd_message_deliveries (
+  snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  snd_queue_id INTEGER NOT NULL,
+  internal_id INTEGER NOT NULL,
+  FOREIGN KEY (conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
+);
+
+CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries (conn_id, snd_queue_id);
+
+ALTER TABLE rcv_messages ADD COLUMN rcv_queue_id INTEGER CHECK (rcv_queue_id NOT NULL);
+UPDATE rcv_messages SET rcv_queue_id = 1;
+
+PRAGMA ignore_check_constraints=OFF;
+|]

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

@@ -0,0 +1,29 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230110_users :: Query
+m20230110_users =
+  [sql|
+PRAGMA ignore_check_constraints=ON;
+
+CREATE TABLE users (
+  user_id INTEGER PRIMARY KEY AUTOINCREMENT
+);
+
+INSERT INTO users (user_id) VALUES (1);
+
+ALTER TABLE connections ADD COLUMN user_id INTEGER CHECK (user_id NOT NULL)
+REFERENCES users ON DELETE CASCADE;
+
+CREATE INDEX idx_connections_user ON connections(user_id);
+
+CREATE INDEX idx_commands_conn_id ON commands(conn_id);
+
+UPDATE connections SET user_id = 1;
+
+PRAGMA ignore_check_constraints=OFF;
+|]

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

@@ -0,0 +1,27 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+-- .lint fkey-indexes
+m20230117_fkey_indexes :: Query
+m20230117_fkey_indexes =
+  [sql|
+CREATE INDEX idx_commands_host_port ON commands(host, port);
+CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id);
+CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations(contact_conn_id);
+CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages(conn_id, internal_snd_id);
+CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages(conn_id, internal_rcv_id);
+CREATE INDEX idx_messages_conn_id ON messages(conn_id);
+CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions(ntf_host, ntf_port);
+CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions(smp_host, smp_port);
+CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens(ntf_host, ntf_port);
+CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id);
+CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages(conn_id, internal_id);
+CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id);
+CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries(conn_id, internal_id);
+CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(conn_id, internal_id);
+CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port);
+|]

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

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230120_delete_errors :: Query
+m20230120_delete_errors =
+  [sql|
+PRAGMA ignore_check_constraints=ON;
+
+ALTER TABLE rcv_queues ADD COLUMN delete_errors INTEGER DEFAULT 0 CHECK (delete_errors NOT NULL);
+UPDATE rcv_queues SET delete_errors = 0;
+
+ALTER TABLE users ADD COLUMN deleted INTEGER DEFAULT 0 CHECK (deleted NOT NULL);
+UPDATE users SET deleted = 0;
+
+PRAGMA ignore_check_constraints=OFF;
+|]

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

@@ -20,7 +20,11 @@ CREATE TABLE connections(
   last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
   smp_agent_version INTEGER NOT NULL DEFAULT 1
   ,
-  duplex_handshake INTEGER NULL DEFAULT 0
+  duplex_handshake INTEGER NULL DEFAULT 0,
+  enable_ntfs INTEGER,
+  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL),
+  user_id INTEGER CHECK(user_id NOT NULL)
+  REFERENCES users ON DELETE CASCADE
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -40,6 +44,11 @@ CREATE TABLE rcv_queues(
   ntf_private_key BLOB,
   ntf_id BLOB,
   rcv_ntf_dh_secret BLOB,
+  rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
+  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,
@@ -57,6 +66,10 @@ CREATE TABLE snd_queues(
   smp_client_version INTEGER NOT NULL DEFAULT 1,
   snd_public_key BLOB,
   e2e_pub_key BLOB,
+  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
@@ -88,6 +101,7 @@ CREATE TABLE rcv_messages(
   external_prev_snd_hash BLOB NOT NULL,
   integrity BLOB NOT NULL,
   user_ack INTEGER NULL DEFAULT 0,
+  rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
   PRIMARY KEY(conn_id, internal_rcv_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -105,15 +119,16 @@ CREATE TABLE snd_messages(
 CREATE TABLE conn_confirmations(
   confirmation_id BLOB NOT NULL PRIMARY KEY,
   conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
-  e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?
-  sender_key BLOB NOT NULL, -- TODO per-queue key. Split?
+  e2e_snd_pub_key BLOB NOT NULL,
+  sender_key BLOB NOT NULL,
   ratchet_state BLOB NOT NULL,
   sender_conn_info BLOB NOT NULL,
   accepted INTEGER NOT NULL,
   own_conn_info BLOB,
   created_at TEXT NOT NULL DEFAULT(datetime('now'))
   ,
-  smp_reply_queues BLOB NULL
+  smp_reply_queues BLOB NULL,
+  smp_client_version INTEGER
 ) WITHOUT ROWID;
 CREATE TABLE conn_invitations(
   invitation_id BLOB NOT NULL PRIMARY KEY,
@@ -186,9 +201,85 @@ 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,
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 ) WITHOUT ROWID;
+CREATE TABLE commands(
+  command_id INTEGER PRIMARY KEY,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  host TEXT,
+  port TEXT,
+  corr_id BLOB NOT NULL,
+  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
+);
+CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
+CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
+CREATE TABLE snd_message_deliveries(
+  snd_message_delivery_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  snd_queue_id INTEGER NOT NULL,
+  internal_id INTEGER NOT NULL,
+  FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED
+);
+CREATE TABLE sqlite_sequence(name,seq);
+CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries(
+  conn_id,
+  snd_queue_id
+);
+CREATE TABLE users(
+  user_id INTEGER PRIMARY KEY AUTOINCREMENT
+  ,
+  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL)
+);
+CREATE INDEX idx_connections_user ON connections(user_id);
+CREATE INDEX idx_commands_conn_id ON commands(conn_id);
+CREATE INDEX idx_commands_host_port ON commands(host, port);
+CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id);
+CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations(
+  contact_conn_id
+);
+CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages(
+  conn_id,
+  internal_snd_id
+);
+CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages(
+  conn_id,
+  internal_rcv_id
+);
+CREATE INDEX idx_messages_conn_id ON messages(conn_id);
+CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions(
+  ntf_host,
+  ntf_port
+);
+CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions(
+  smp_host,
+  smp_port
+);
+CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens(
+  ntf_host,
+  ntf_port
+);
+CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id);
+CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id);
+CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port);

src/Simplex/Messaging/Agent/TAsyncs.hs

@@ -0,0 +1,25 @@
+module Simplex.Messaging.Agent.TAsyncs where
+
+import Control.Concurrent.STM (stateTVar)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import UnliftIO.Async (Async, async)
+import UnliftIO.STM
+
+data TAsyncs = TAsyncs
+  { actionId :: TVar Int,
+    actions :: TMap Int (Async ())
+  }
+
+newTAsyncs :: STM TAsyncs
+newTAsyncs = TAsyncs <$> newTVar 0 <*> TM.empty
+
+newAsyncAction :: MonadUnliftIO m => (Int -> m ()) -> TAsyncs -> m ()
+newAsyncAction action as = do
+  aId <- atomically $ stateTVar (actionId as) $ \i -> (i + 1, i + 1)
+  a <- async $ action aId
+  atomically $ TM.insert aId a $ actions as
+
+removeAsyncAction :: Int -> TAsyncs -> STM ()
+removeAsyncAction aId = TM.delete aId . actions

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -0,0 +1,65 @@
+module Simplex.Messaging.Agent.TRcvQueues
+  ( TRcvQueues,
+    empty,
+    clear,
+    deleteConn,
+    hasConn,
+    getConns,
+    addQueue,
+    deleteQueue,
+    getSessQueues,
+    getDelSessQueues,
+  )
+where
+
+import Control.Concurrent.STM
+import qualified Data.Map.Strict as M
+import Data.Set (Set)
+import qualified Data.Set as S
+import Simplex.Messaging.Agent.Protocol (ConnId)
+import Simplex.Messaging.Agent.Store (RcvQueue (..), UserId)
+import Simplex.Messaging.Protocol (RecipientId, SMPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+
+newtype TRcvQueues = TRcvQueues (TMap (UserId, SMPServer, RecipientId) RcvQueue)
+
+empty :: STM TRcvQueues
+empty = TRcvQueues <$> TM.empty
+
+clear :: TRcvQueues -> STM ()
+clear (TRcvQueues qs) = TM.clear qs
+
+deleteConn :: ConnId -> TRcvQueues -> STM ()
+deleteConn cId (TRcvQueues qs) = modifyTVar' qs $ M.filter (\rq -> cId /= connId rq)
+
+hasConn :: ConnId -> TRcvQueues -> STM Bool
+hasConn cId (TRcvQueues qs) = any (\rq -> cId == connId rq) <$> readTVar qs
+
+getConns :: TRcvQueues -> STM (Set ConnId)
+getConns (TRcvQueues qs) = M.foldr' (S.insert . connId) S.empty <$> readTVar qs
+
+addQueue :: RcvQueue -> TRcvQueues -> STM ()
+addQueue rq (TRcvQueues qs) = TM.insert (qKey rq) rq qs
+
+deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
+deleteQueue rq (TRcvQueues qs) = TM.delete (qKey rq) qs
+
+getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
+getSessQueues tSess (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
+  where
+    addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs'
+
+getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
+getDelSessQueues tSess (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ ([], M.empty)
+  where
+    addQ (removed, qs') rq
+      | rq `isSession` tSess = (rq : removed, qs')
+      | otherwise = (removed, M.insert (qKey rq) rq qs')
+
+isSession :: RcvQueue -> (UserId, SMPServer, Maybe ConnId) -> Bool
+isSession rq (uId, srv, connId_) =
+  userId rq == uId && server rq == srv && maybe True (connId rq ==) connId_
+
+qKey :: RcvQueue -> (UserId, SMPServer, ConnId)
+qKey rq = (userId rq, server rq, connId rq)

src/Simplex/Messaging/Client.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -24,30 +26,47 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
-    ProtocolClient (thVersion, sessionId),
+    TransportSession,
+    ProtocolClient (thVersion, sessionId, sessionTs),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
+    clientServer,
+    transportHost',
+    transportSession',
 
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
+    subscribeSMPQueues,
     getSMPMessage,
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
     disableSMPQueueNotifications,
+    enableSMPQueuesNtfs,
+    disableSMPQueuesNtfs,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
     deleteSMPQueue,
+    deleteSMPQueues,
     sendProtocolCommand,
 
     -- * Supporting types and client configuration
     ProtocolClientError (..),
+    SMPClientError,
     ProtocolClientConfig (..),
+    NetworkConfig (..),
+    TransportSessionMode (..),
     defaultClientConfig,
+    defaultNetworkConfig,
+    transportClientConfig,
+    chooseTransportHost,
+    proxyUsername,
+    temporaryClientError,
     ServerTransmission,
+    ClientCommand,
   )
 where
 
@@ -58,44 +77,139 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Either (rights)
+import Data.Functor (($>))
+import Data.Int (Int64)
+import Data.List (find)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import GHC.Generics (Generic)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
 import Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (runTransportClient)
+import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (bshow, liftError, raceAny_)
+import Simplex.Messaging.Util (bshow, raceAny_)
 import Simplex.Messaging.Version
 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
-  { action :: Async (),
-    connected :: TVar Bool,
+data ProtocolClient err msg = ProtocolClient
+  { action :: Maybe (Async ()),
     sessionId :: SessionId,
+    sessionTs :: UTCTime,
     thVersion :: Version,
-    protocolServer :: ProtoServer msg,
+    client_ :: PClient err msg
+  }
+
+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),
-    sndQ :: TBQueue SentRawTransmission,
-    rcvQ :: TBQueue (SignedTransmission msg),
+    sentCommands :: TMap CorrId (Request err msg),
+    sndQ :: TBQueue (NonEmpty SentRawTransmission),
+    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)
 
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
+type ServerTransmission msg = (TransportSession msg, Version, SessionId, QueueId, msg)
+
+data HostMode
+  = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
+    HMOnionViaSocks
+  | -- | prefer (or require) onion hosts
+    HMOnion
+  | -- | prefer (or require) public hosts
+    HMPublic
+  deriving (Eq, Show, Generic)
+
+instance FromJSON HostMode where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM"
+
+instance ToJSON HostMode where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM"
+
+-- | network configuration for the client
+data NetworkConfig = NetworkConfig
+  { -- | use SOCKS5 proxy
+    socksProxy :: Maybe SocksProxy,
+    -- | determines critera which host is chosen from the list
+    hostMode :: HostMode,
+    -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
+    requiredHostMode :: Bool,
+    -- | transport sessions are created per user or per entity
+    sessionMode :: TransportSessionMode,
+    -- | timeout for the initial client TCP/TLS connection (microseconds)
+    tcpConnectTimeout :: Int,
+    -- | timeout of protocol commands (microseconds)
+    tcpTimeout :: Int,
+    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
+    tcpKeepAlive :: Maybe KeepAliveOpts,
+    -- | period for SMP ping commands (microseconds, 0 to disable)
+    smpPingInterval :: Int,
+    -- | the count of PING errors after which SMP client terminates (and will be reconnected), 0 to disable
+    smpPingCount :: Int,
+    logTLSErrors :: Bool
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON NetworkConfig where
+  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
+  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+
+data TransportSessionMode = TSMUser | TSMEntity
+  deriving (Eq, Show, Generic)
+
+instance ToJSON TransportSessionMode where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "TSM"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TSM"
+
+instance FromJSON TransportSessionMode where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "TSM"
+
+defaultNetworkConfig :: NetworkConfig
+defaultNetworkConfig =
+  NetworkConfig
+    { socksProxy = Nothing,
+      hostMode = HMOnionViaSocks,
+      requiredHostMode = False,
+      sessionMode = TSMUser,
+      tcpConnectTimeout = 7_500_000,
+      tcpTimeout = 5_000_000,
+      tcpKeepAlive = Just defaultKeepAliveOpts,
+      smpPingInterval = 600_000_000, -- 10min
+      smpPingCount = 3,
+      logTLSErrors = False
+    }
+
+transportClientConfig :: NetworkConfig -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
+  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
 
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
@@ -103,12 +217,8 @@ data ProtocolClientConfig = ProtocolClientConfig
     qSize :: Natural,
     -- | default server port if port is not specified in ProtocolServer
     defaultTransport :: (ServiceName, ATransport),
-    -- | timeout of TCP commands (microseconds)
-    tcpTimeout :: Int,
-    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    -- | period for SMP ping commands (microseconds)
-    smpPing :: Int,
+    -- | network configuration
+    networkConfig :: NetworkConfig,
     -- | SMP client-server protocol version range
     smpServerVRange :: VersionRange
   }
@@ -119,44 +229,76 @@ defaultClientConfig =
   ProtocolClientConfig
     { qSize = 64,
       defaultTransport = ("443", transport @TLS),
-      tcpTimeout = 5_000_000,
-      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPing = 600_000_000, -- 10min
+      networkConfig = defaultNetworkConfig,
       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 err) TransportHost
+chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
+  firstOrError $ case hostMode of
+    HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
+    HMOnion -> onionHost
+    HMPublic -> publicHost
+  where
+    firstOrError
+      | requiredHostMode = maybe (Left PCEIncompatibleHost) Right
+      | otherwise = Right . fromMaybe (L.head hosts)
+    isOnionHost = \case THOnionHost _ -> True; _ -> False
+    onionHost = find isOnionHost hosts
+    publicHost = find (not . isOnionHost) hosts
+
+clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
+clientServer = B.unpack . strEncode . snd3 . transportSession . client_
+  where
+    snd3 (_, s, _) = s
+
+transportHost' :: ProtocolClient err msg -> TransportHost
+transportHost' = transportHost . client_
+
+transportSession' :: ProtocolClient err msg -> TransportSession msg
+transportSession' = transportSession . client_
+
+type UserId = Int64
+
+-- | Transport session key - includes entity ID if `sessionMode = TSMEntity`.
+type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
 
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
-  (atomically mkProtocolClient >>= runClient useTransport)
-    `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
+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 ->
+      (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
+        `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
+    Left e -> pure $ Left e
   where
-    mkProtocolClient :: STM (ProtocolClient msg)
-    mkProtocolClient = do
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    mkProtocolClient :: TransportHost -> STM (PClient err msg)
+    mkProtocolClient transportHost = do
       connected <- newTVar False
+      pingErrorCount <- newTVar 0
       clientCorrId <- newTVar 0
       sentCommands <- TM.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        ProtocolClient
-          { action = undefined,
-            sessionId = undefined,
-            thVersion = undefined,
-            connected,
-            protocolServer,
+        PClient
+          { connected,
+            transportSession,
+            transportHost,
             tcpTimeout,
+            pingErrorCount,
             clientCorrId,
             sentCommands,
             sndQ,
@@ -164,57 +306,67 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
-    runClient (port', ATransport t) c = do
-      thVar <- newEmptyTMVarIO
+    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
+          username = proxyUsername transportSession
       action <-
         async $
-          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
-            `finally` atomically (putTMVar thVar $ Left PCENetworkError)
-      th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
-      pure $ case th_ of
-        Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
+          runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
+            `finally` atomically (putTMVar cVar $ Left PCENetworkError)
+      c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
+      pure $ case c_ of
+        Just (Right c') -> Right c' {action = Just action}
         Just (Left e) -> Left e
         Nothing -> Left PCENetworkError
 
     useTransport :: (ServiceName, ATransport)
-    useTransport = case port protocolServer of
+    useTransport = case port srv of
       "" -> defaultTransport cfg
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
-    client _ c thVar h =
-      runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
-        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
+    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 @err @msg h (keyHash srv) smpServerVRange) >>= \case
+        Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {sessionId, thVersion} -> do
+          sessionTs <- getCurrentTime
+          let c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs}
           atomically $ do
             writeTVar (connected c) True
-            putTMVar thVar $ Right th
-          let c' = c {sessionId, thVersion} :: ProtocolClient msg
-          -- TODO remove ping if 0 is passed (or Nothing?)
-          raceAny_ [send c' th, process c', receive c' th, ping c']
-            `finally` disconnected
+            putTMVar cVar $ Right c'
+          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 ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    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 ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
+    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 c = forever $ do
-      threadDelay smpPing
-      runExceptT $ sendProtocolCommand c Nothing "" protocolPing
+    ping :: ProtocolClient err msg -> IO ()
+    ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do
+      threadDelay smpPingInterval
+      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
+        _ -> ping c -- sendProtocolCommand resets pingErrorCount
+      where
+        maxCnt = smpPingCount networkConfig
 
-    process :: ProtocolClient msg -> IO ()
-    process c@ProtocolClient {rcvQ, sentCommands} = forever $ do
-      (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
+    process :: ProtocolClient err msg -> IO ()
+    process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
+
+    processMsg :: ProtocolClient err msg -> SignedTransmission err msg -> IO ()
+    processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, qId, respOrErr)) =
       if B.null $ bs corrId
-        then sendMsg qId respOrErr
+        then sendMsg respOrErr
         else do
           atomically (TM.lookup corrId sentCommands) >>= \case
-            Nothing -> sendMsg qId respOrErr
+            Nothing -> sendMsg respOrErr
             Just Request {queueId, responseVar} -> atomically $ do
               TM.delete corrId sentCommands
               putTMVar responseVar $
@@ -226,24 +378,26 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
                       _ -> Right r
                   else Left . PCEUnexpectedResponse $ bshow respOrErr
       where
-        sendMsg :: QueueId -> Either ErrorType msg -> IO ()
-        sendMsg qId = \case
+        sendMsg :: Either err msg -> IO ()
+        sendMsg = \case
           Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
-          -- TODO send everything else to errQ and log in agent
-          _ -> return ()
+          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 = uninterruptibleCancel . action
+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.
@@ -255,15 +409,26 @@ data ProtocolClientError
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
     PCENetworkError
+  | -- | No host compatible with network configuration
+    PCEIncompatibleHost
   | -- | 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
@@ -272,73 +437,96 @@ createSMPQueue ::
   RcvPrivateSignKey ->
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
-  ExceptT ProtocolClientError IO QueueIdsKeys
-createSMPQueue c rpKey rKey dhKey =
-  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
+  Maybe BasicAuth ->
+  ExceptT SMPClientError IO QueueIdsKeys
+createSMPQueue c rpKey rKey dhKey auth =
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
     IDS qik -> pure qik
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | 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 ()
-    cmd@MSG {} -> writeSMPMessage c rId cmd
+    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> ExceptT ProtocolClientError IO ()
-writeSMPMessage c rId msg =
-  liftIO . atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
+-- | Subscribe to multiple SMP queues batching commands if supported.
+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
+    response ((_, rId), r) = case r of
+      Right OK -> pure $ Right ()
+      Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
+      Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
+      Left e -> pure $ Left e
 
-serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
-serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
-  (protocolServer, thVersion, sessionId, entityId, message)
+writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
+writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
+
+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
-    cmd@(MSG msg) -> do
-      writeSMPMessage c rId cmd
-      pure $ Just msg
+    cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | 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 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
+    response = \case
+      Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
+      Right r -> Left . PCEUnexpectedResponse $ bshow r
+      Left e -> Left e
+
 -- | 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 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 ()
@@ -347,67 +535,90 @@ 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 ()
-    cmd@MSG {} -> writeSMPMessage c rId cmd
+    cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Irreversibly suspend SMP queue.
 -- 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 -> QueueId -> ExceptT ProtocolClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 
-okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+-- | Delete multiple SMP queues batching commands if supported.
+deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+deleteSMPQueues = okSMPCommands DEL
+
+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 SMPClientError ()))
+okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs
+  where
+    aCmd = Cmd sParty cmd
+    cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
+    response = \case
+      Right OK -> Right ()
+      Right r -> Left . PCEUnexpectedResponse $ bshow r
+      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 Protocol command
-sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
-sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, thVersion, tcpTimeout} pKey qId cmd = do
-  corrId <- lift_ getNextCorrId
-  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
-  ExceptT $ sendRecv corrId t
-  where
-    lift_ :: STM a -> ExceptT ProtocolClientError IO a
-    lift_ action = ExceptT $ Right <$> atomically action
+-- | Send multiple commands with batching and collect responses
+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
+  forConcurrently ts $ \case
+    Right (_, r) -> withTimeout c $ atomically $ takeTMVar r
+    Left e -> pure $ Left e
 
+-- | Send Protocol command
+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 err msg) -> IO (Response err msg)
+    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c (atomically $ takeTMVar r)
+
+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 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)
+  r <- liftIO . atomically $ mkRequest corrId
+  pure (t, r)
+  where
     getNextCorrId :: STM CorrId
     getNextCorrId = do
       i <- stateTVar clientCorrId $ \i -> (i, i + 1)
       pure . CorrId $ bshow i
-
-    signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
-    signTransmission t = case pKey of
-      Nothing -> return (Nothing, t)
-      Just pk -> do
-        sig <- liftError PCESignatureError $ C.sign pk t
-        return (Just sig, t)
-
-    -- two separate "atomically" needed to avoid blocking
-    sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
-    sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
-      where
-        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
-
-    send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
-    send corrId t = do
+    signTransmission :: ByteString -> SentRawTransmission
+    signTransmission t = ((`C.sign` t) <$> pKey, t)
+    mkRequest :: CorrId -> STM (TMVar (Response err msg))
+    mkRequest corrId = do
       r <- newEmptyTMVar
       TM.insert corrId (Request qId r) sentCommands
-      writeTBQueue sndQ t
-      return r
+      pure r

src/Simplex/Messaging/Client/Agent.hs

@@ -26,6 +26,7 @@ import Numeric.Natural
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -37,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)
@@ -110,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
@@ -123,19 +124,19 @@ 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 {tcpTimeout} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
+      let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
+      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
       liftEither $ case smpClient_ of
         Just (Right smpClient) -> Right smpClient
         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
@@ -149,20 +150,20 @@ 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 $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
+    connectClient :: ExceptT SMPClientError IO SMPClient
+    connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: SMPClient -> IO ()
+    clientDisconnected _ = do
       removeClientAndSubs >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
@@ -187,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
@@ -206,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
@@ -220,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 ()
@@ -240,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
@@ -264,9 +265,9 @@ subscribeQueue ca srv sub = do
 
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
-  B.pack $ host <> if null port then "" else ':' : 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

@@ -67,7 +67,9 @@ module Simplex.Messaging.Crypto
 
     -- * key encoding/decoding
     encodePubKey,
+    decodePubKey,
     encodePrivKey,
+    decodePrivKey,
     pubKeyBytes,
 
     -- * sign/verify
@@ -89,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,
@@ -108,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
@@ -138,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
@@ -151,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)
@@ -688,9 +704,13 @@ 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
+  | -- | padded message is shorter than 2 bytes
+    CryptoInvalidMsgError
   | -- | failure parsing message header
     CryptoHeaderError String
   | -- | no sending chain key in ratchet state
@@ -738,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.
 --
@@ -773,38 +809,54 @@ 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
+
 pad :: ByteString -> Int -> Either CryptoError ByteString
 pad msg paddedLen
-  | padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
+  | len <= maxMsgLen && padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
   | otherwise = Left CryptoLargeMsgError
   where
     len = B.length msg
@@ -812,8 +864,8 @@ pad msg paddedLen
 
 unPad :: ByteString -> Either CryptoError ByteString
 unPad padded
-  | B.length rest >= len = Right $ B.take len rest
-  | otherwise = Left CryptoLargeMsgError
+  | B.length lenWrd == 2 && B.length rest >= len = Right $ B.take len rest
+  | otherwise = Left CryptoInvalidMsgError
   where
     (lenWrd, rest) = B.splitAt 2 padded
     len = fromIntegral $ decodeWord16 lenWrd
@@ -853,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
@@ -860,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
@@ -868,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
 
@@ -883,12 +950,12 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
 -- | Message signing.
 --
 -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages.
-sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> ExceptT CryptoError IO (Signature a)
-sign' (PrivateKeyEd25519 pk k) msg = pure . SignatureEd25519 $ Ed25519.sign pk k msg
-sign' (PrivateKeyEd448 pk k) msg = pure . SignatureEd448 $ Ed448.sign pk k msg
+sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
+sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
+sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
 
-sign :: APrivateSignKey -> ByteString -> ExceptT CryptoError IO ASignature
-sign (APrivateSignKey a k) = fmap (ASignature a) . sign' k
+sign :: APrivateSignKey -> ByteString -> ASignature
+sign (APrivateSignKey a k) = ASignature a . sign' k
 
 -- | Signature verification.
 --
@@ -908,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
@@ -922,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
@@ -931,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
@@ -942,37 +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 = do
-  g <- readTVar gVar
-  let (bytes, g') = randomBytesGenerate n g
-  writeTVar gVar g'
-  return bytes
+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,182 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Crypto.Lazy
+  ( 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 (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.
+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/Crypto/Ratchet.hs

@@ -41,11 +41,11 @@ import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE')
 import Simplex.Messaging.Util (tryE)
 import Simplex.Messaging.Version
 
-e2eEncryptVersion :: Version
-e2eEncryptVersion = 1
+currentE2EEncryptVersion :: Version
+currentE2EEncryptVersion = 2
 
-e2eEncryptVRange :: VersionRange
-e2eEncryptVRange = mkVersionRange 1 e2eEncryptVersion
+supportedE2EEncryptVRange :: VersionRange
+supportedE2EEncryptVRange = mkVersionRange 1 currentE2EEncryptVersion
 
 data E2ERatchetParams (a :: Algorithm)
   = E2ERatchetParams Version (PublicKey a) (PublicKey a)
@@ -96,20 +96,27 @@ data RatchetInitParams = RatchetInitParams
   deriving (Eq, Show)
 
 x3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
-x3dhSnd spk1 spk2 (E2ERatchetParams _ rk1 rk2) =
-  x3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
+x3dhSnd spk1 spk2 (E2ERatchetParams v rk1 rk2) =
+  x3dh v (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
 
 x3dhRcv :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
-x3dhRcv rpk1 rpk2 (E2ERatchetParams _ sk1 sk2) =
-  x3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
+x3dhRcv rpk1 rpk2 (E2ERatchetParams v sk1 sk2) =
+  x3dh v (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
 
-x3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
-x3dh (sk1, rk1) dh1 dh2 dh3 =
+x3dh :: DhAlgorithm a => Version -> (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
+x3dh v (sk1, rk1) dh1 dh2 dh3 =
   RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk}
   where
     assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
-    (hk, rest) = B.splitAt 32 $ dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
-    (nhk, sk) = B.splitAt 32 rest
+    dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
+    (hk, nhk, sk)
+      -- for backwards compatibility with clients using agent version before 3.4.0
+      | v == 1 =
+        let (hk', rest) = B.splitAt 32 dhs
+         in uncurry (hk',,) $ B.splitAt 32 rest
+      | otherwise =
+        let salt = B.replicate 64 '\0'
+         in hkdf3 salt dhs "SimpleXX3DH"
 
 type RatchetX448 = Ratchet 'X448
 
@@ -210,12 +217,12 @@ instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
 -- Please note that sPKey is not stored, and its public part together with random salt
 -- is sent to the recipient.
 initSndRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
-initSndRatchet rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
+  forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
+initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
   -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr))
   let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs
    in Ratchet
-        { rcVersion = e2eEncryptVRange,
+        { rcVersion,
           rcAD = assocData,
           rcDHRs,
           rcRK,
@@ -233,10 +240,10 @@ initSndRatchet rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rc
 -- Please note that the public part of rcDHRs was sent to the sender
 -- as part of the connection request and random salt was received from the sender.
 initRcvRatchet ::
-  forall a. (AlgorithmI a, DhAlgorithm a) => PrivateKey a -> RatchetInitParams -> Ratchet a
-initRcvRatchet rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
+  forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PrivateKey a -> RatchetInitParams -> Ratchet a
+initRcvRatchet rcVersion rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
   Ratchet
-    { rcVersion = e2eEncryptVRange,
+    { rcVersion,
       rcAD = assocData,
       rcDHRs,
       rcRK = ratchetKey,
@@ -465,7 +472,6 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
     decryptMessage :: MessageKey -> EncRatchetMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
     decryptMessage (MessageKey mk iv) EncRatchetMessage {emHeader, emBody, emAuthTag} =
       -- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
-      -- TODO add associated data
       tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag
 
 rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> (RatchetKey, RatchetKey, Key)

src/Simplex/Messaging/Encoding.hs

@@ -13,6 +13,7 @@ module Simplex.Messaging.Encoding
     Large (..),
     smpEncodeList,
     smpListP,
+    lenEncode,
   )
 where
 

src/Simplex/Messaging/Encoding/String.hs

@@ -6,6 +6,7 @@ module Simplex.Messaging.Encoding.String
     StrEncoding (..),
     Str (..),
     strP_,
+    _strP,
     strToJSON,
     strToJEncoding,
     strParseJSON,
@@ -35,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 ((<$?>))
@@ -74,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
@@ -93,10 +98,16 @@ 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 #-}
-  strP = strP
+  strP = smpP
   {-# INLINE strP #-}
 
 instance StrEncoding Bool where
@@ -171,6 +182,9 @@ instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncodin
 strP_ :: StrEncoding a => Parser a
 strP_ = strP <* A.space
 
+_strP :: StrEncoding a => Parser a
+_strP = A.space *> strP
+
 strToJSON :: StrEncoding a => a -> J.Value
 strToJSON = J.String . decodeLatin1 . 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 #-}
@@ -23,6 +24,7 @@ import Data.Type.Equality
 import Data.Word (Word16)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -145,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
@@ -182,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)
@@ -201,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
@@ -218,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
 
@@ -238,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
@@ -282,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)
@@ -305,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
@@ -332,12 +347,16 @@ data SMPQueueNtf = SMPQueueNtf
 instance Encoding SMPQueueNtf where
   smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
   smpP = do
-    (smpServer, notifierId) <- smpP
-    pure $ SMPQueueNtf {smpServer, notifierId}
+    smpServer <- updateSMPServerHosts <$> smpP
+    notifierId <- smpP
+    pure SMPQueueNtf {smpServer, notifierId}
 
 instance StrEncoding SMPQueueNtf where
   strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
-  strP = SMPQueueNtf <$> strP <* A.char '/' <*> strP
+  strP = do
+    smpServer <- updateSMPServerHosts <$> strP
+    notifierId <- A.char '/' *> strP
+    pure SMPQueueNtf {smpServer, notifierId}
 
 data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
   deriving (Eq, Ord, Show)
@@ -382,7 +401,7 @@ instance StrEncoding DeviceToken where
   strP = DeviceToken <$> strP <* A.space <*> hexStringP
     where
       hexStringP =
-        A.takeWhile (\c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')) >>= \s ->
+        A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s ->
           if even (B.length s) then pure s else fail "odd number of hex characters"
 
 instance ToJSON DeviceToken where

src/Simplex/Messaging/Notifications/Server.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -13,71 +15,130 @@ module Simplex.Messaging.Notifications.Server where
 import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple
 import Control.Monad.Except
-import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
-import Crypto.Random (MonadRandom)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import Data.List (intercalate)
 import Data.Map.Strict (Map)
 import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+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
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
+import Simplex.Messaging.Server.Stats
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
 import Simplex.Messaging.Transport.Server (runTransportServer)
 import Simplex.Messaging.Util
+import System.Exit (exitFailure)
+import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
 import System.Mem.Weak (deRefWeak)
-import UnliftIO (IOMode (..), async, uninterruptibleCancel)
+import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
 import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
+import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.STM
 
-runNtfServer :: (MonadRandom m, MonadUnliftIO m) => NtfServerConfig -> m ()
+runNtfServer :: NtfServerConfig -> IO ()
 runNtfServer cfg = do
   started <- newEmptyTMVarIO
   runNtfServerBlocking started cfg
 
-runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfServerConfig -> m ()
+runNtfServerBlocking :: TMVar Bool -> NtfServerConfig -> IO ()
 runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
 
-ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfig -> TMVar Bool -> m ()
-ntfServer NtfServerConfig {transports} started = do
+type M a = ReaderT NtfEnv IO a
+
+ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
+ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
+  restoreServerStats
   s <- asks subscriber
   ps <- asks pushServer
   subs <- readTVarIO =<< asks (subscriptions . store)
   void . forkIO $ resubscribe s subs
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports) `finally` stopServer
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
   where
-    runServer :: (ServiceName, ATransport) -> m ()
+    runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams (runClient t)
+      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
 
-    runClient :: Transport c => TProxy c -> c -> m ()
+    runClient :: Transport c => TProxy c -> c -> M ()
     runClient _ h = do
       kh <- asks serverIdentity
       liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
         Right th -> runNtfClientTransport th
         Left _ -> pure ()
 
-    stopServer :: m ()
+    stopServer :: M ()
     stopServer = do
       withNtfLog closeStoreLog
+      saveServerStats
       asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
 
-resubscribe :: (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> m ()
+    serverStatsThread_ :: NtfServerConfig -> [M ()]
+    serverStatsThread_ NtfServerConfig {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 $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
+      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
+      let interval = 1000000 * logInterval
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
+          ts <- getCurrentTime
+          fromTime' <- atomically $ swapTVar fromTime ts
+          tknCreated' <- atomically $ swapTVar tknCreated 0
+          tknVerified' <- atomically $ swapTVar tknVerified 0
+          tknDeleted' <- atomically $ swapTVar tknDeleted 0
+          subCreated' <- atomically $ swapTVar subCreated 0
+          subDeleted' <- atomically $ swapTVar subDeleted 0
+          ntfReceived' <- atomically $ swapTVar ntfReceived 0
+          ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
+          tkn <- atomically $ periodStatCounts activeTokens ts
+          sub <- atomically $ periodStatCounts activeSubs ts
+          hPutStrLn h $
+            intercalate
+              ","
+              [ iso8601Show $ utctDay fromTime',
+                show tknCreated',
+                show tknVerified',
+                show tknDeleted',
+                show subCreated',
+                show subDeleted',
+                show ntfReceived',
+                show ntfDelivered',
+                dayCount tkn,
+                weekCount tkn,
+                monthCount tkn,
+                dayCount sub,
+                weekCount sub,
+                monthCount sub
+              ]
+          threadDelay interval
+
+resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
 resubscribe NtfSubscriber {newSubQ} subs = do
   d <- asks $ resubscribeDelay . config
   forM_ subs $ \sub@NtfSubData {} ->
@@ -86,11 +147,11 @@ resubscribe NtfSubscriber {newSubQ} subs = do
       threadDelay d
   liftIO $ logInfo "SMP connections resubscribed"
 
-ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
+ntfSubscriber :: NtfSubscriber -> M ()
 ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
   raceAny_ [subscribe, receiveSMP, receiveAgent]
   where
-    subscribe :: m ()
+    subscribe :: M ()
     subscribe =
       forever $
         atomically (readTBQueue newSubQ) >>= \case
@@ -98,7 +159,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
             SMPSubscriber {newSubQ = subscriberSubQ} <- getSMPSubscriber smpServer
             atomically $ writeTQueue subscriberSubQ sub
 
-    getSMPSubscriber :: SMPServer -> m SMPSubscriber
+    getSMPSubscriber :: SMPServer -> M SMPSubscriber
     getSMPSubscriber smpServer =
       atomically (TM.lookup smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
       where
@@ -109,7 +170,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
           atomically . writeTVar subThreadId $ Just tId
           pure sub
 
-    runSMPSubscriber :: SMPSubscriber -> m ()
+    runSMPSubscriber :: SMPSubscriber -> M ()
     runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
       forever $
         atomically (peekTQueue subscriberSubQ)
@@ -127,42 +188,46 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
                   PCENetworkError -> pure ()
                   _ -> void . atomically $ readTQueue subscriberSubQ
 
-    receiveSMP :: m ()
+    receiveSMP :: M ()
     receiveSMP = forever $ do
-      (srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
+      ((_, srv, _), _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
       let smpQueue = SMPQueueNtf srv ntfId
       case msg of
         SMP.NMSG nmsgNonce encNMsgMeta -> do
           ntfTs <- liftIO getSystemTime
           st <- asks store
           NtfPushServer {pushQ} <- asks pushServer
+          stats <- asks serverStats
+          atomically $ updatePeriodStats (activeSubs stats) ntfId
           atomically $
             findNtfSubscriptionToken st smpQueue
               >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
+          incNtfStat ntfReceived
         SMP.END -> updateSubStatus smpQueue NSEnd
         _ -> pure ()
-      pure ()
 
     receiveAgent =
       forever $
         atomically (readTBQueue agentQ) >>= \case
           CAConnected _ -> pure ()
           CADisconnected srv subs -> do
-            logInfo . T.pack $ "SMP server disconnected " <> host srv <> " (" <> show (length subs) <> ") subscriptions"
+            logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
             forM_ subs $ \(_, ntfId) -> do
               let smpQueue = SMPQueueNtf srv ntfId
               updateSubStatus smpQueue NSInactive
           CAReconnected srv ->
-            logInfo $ "SMP server reconnected " <> T.pack (host srv)
+            logInfo $ "SMP server reconnected " <> showServer' srv
           CAResubscribed srv sub -> do
             let ntfId = snd sub
                 smpQueue = SMPQueueNtf srv ntfId
             updateSubStatus smpQueue NSActive
           CASubError srv (_, ntfId) err -> do
-            logError . T.pack $ "SMP subscription error on server " <> host srv <> ": " <> show err
+            logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
             handleSubError (SMPQueueNtf srv ntfId) err
+      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
@@ -170,11 +235,12 @@ 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 ()
       where
-        updateErr :: Show e => ByteString -> e -> m ()
+        updateErr :: Show e => ByteString -> e -> M ()
         updateErr errType e = updateSubStatus smpQueue . NSErr $ errType <> bshow e
 
     updateSubStatus smpQueue status = do
@@ -186,27 +252,33 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
               withNtfLog $ \sl -> logSubscriptionStatus sl ntfSubId status
           )
 
-ntfPush :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfPushServer -> m ()
+ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
   (tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
   liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
   status <- readTVarIO tknStatus
-  case (status, ntf) of
-    (_, PNVerification _) -> do
-      -- TODO check token status
-      deliverNotification pp tkn ntf >>= \case
-        Right _ -> do
-          status_ <- atomically $ stateTVar tknStatus $ \status' -> if status' == NTActive then (Nothing, NTActive) else (Just NTConfirmed, NTConfirmed)
-          forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
-        _ -> pure ()
-    (NTActive, PNCheckMessages) -> do
+  case ntf of
+    PNVerification _
+      | status /= NTInvalid && status /= NTExpired ->
+        deliverNotification pp tkn ntf >>= \case
+          Right _ -> do
+            status_ <- atomically $ stateTVar tknStatus $ \status' -> if status' == NTActive then (Nothing, NTActive) else (Just NTConfirmed, NTConfirmed)
+            forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
+          _ -> pure ()
+      | otherwise -> logError "bad notification token status"
+    PNCheckMessages -> checkActiveTkn status $ do
       void $ deliverNotification pp tkn ntf
-    (NTActive, PNMessage {}) -> do
+    PNMessage {} -> checkActiveTkn status $ do
+      stats <- asks serverStats
+      atomically $ updatePeriodStats (activeTokens stats) ntfTknId
       void $ deliverNotification pp tkn ntf
-    _ -> do
-      liftIO $ logError "bad notification token status"
+      incNtfStat ntfDelivered
   where
-    deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> m (Either PushProviderError ())
+    checkActiveTkn :: NtfTknStatus -> M () -> M ()
+    checkActiveTkn status action
+      | status == NTActive = action
+      | otherwise = liftIO $ logError "bad notification token status"
+    deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> M (Either PushProviderError ())
     deliverNotification pp tkn@NtfTknData {ntfTknId, tknStatus} ntf = do
       deliver <- liftIO $ getPushClient s pp
       liftIO (runExceptT $ deliver tkn ntf) >>= \case
@@ -214,23 +286,22 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
         Left e -> case e of
           PPConnection _ -> retryDeliver
           PPRetryLater -> retryDeliver
-          -- TODO alert
           PPCryptoError _ -> err e
           PPResponseError _ _ -> err e
           PPTokenInvalid -> updateTknStatus NTInvalid >> err e
           PPPermanentError -> err e
       where
-        retryDeliver :: m (Either PushProviderError ())
+        retryDeliver :: M (Either PushProviderError ())
         retryDeliver = do
           deliver <- liftIO $ newPushClient s pp
           liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right)
-        updateTknStatus :: NtfTknStatus -> m ()
+        updateTknStatus :: NtfTknStatus -> M ()
         updateTknStatus status = do
           atomically $ writeTVar tknStatus status
           withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
         err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e
 
-runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m ()
+runNtfClientTransport :: Transport c => THandle c -> M ()
 runNtfClientTransport th@THandle {sessionId} = do
   qSize <- asks $ clientQSize . config
   ts <- liftIO getSystemTime
@@ -238,32 +309,33 @@ runNtfClientTransport th@THandle {sessionId} = do
   s <- asks subscriber
   ps <- asks pushServer
   expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
-    `finally` clientDisconnected c
+  raceAny_ ([liftIO $ send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg)
+    `finally` liftIO (clientDisconnected c)
   where
-    disconnectThread_ c expCfg = maybe [] ((: []) . disconnectTransport th c activeAt) expCfg
+    disconnectThread_ c expCfg = maybe [] ((: []) . liftIO . disconnectTransport th c activeAt) expCfg
 
-clientDisconnected :: MonadUnliftIO m => NtfServerClient -> m ()
+clientDisconnected :: NtfServerClient -> IO ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
-receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
+receive :: Transport c => THandle c -> NtfServerClient -> M ()
 receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
-  t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-  logDebug "received transmission"
-  case cmdOrError of
-    Left e -> write sndQ (corrId, entId, NRErr e)
-    Right cmd ->
-      verifyNtfTransmission t cmd >>= \case
-        VRVerified req -> write rcvQ req
-        VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
+  ts <- liftIO $ tGet th
+  forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
+    atomically . writeTVar activeAt =<< liftIO getSystemTime
+    logDebug "received transmission"
+    case cmdOrError of
+      Left e -> write sndQ (corrId, entId, NRErr e)
+      Right cmd ->
+        verifyNtfTransmission t cmd >>= \case
+          VRVerified req -> write rcvQ req
+          VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
   where
     write q t = atomically $ writeTBQueue q t
 
-send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
+send :: Transport c => THandle c -> NtfServerClient -> IO ()
 send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
+  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
   atomically . writeTVar activeAt =<< liftIO getSystemTime
 
 -- instance Show a => Show (TVar a) where
@@ -271,8 +343,7 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = for
 
 data VerificationResult = VRVerified NtfRequest | VRFailed
 
-verifyNtfTransmission ::
-  forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => 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
@@ -293,28 +364,26 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
       s_ <- atomically $ findNtfSubscription st smpQueue
       case s_ of
         Nothing -> do
-          -- TODO move active token check here to differentiate error
           t_ <- atomically $ getActiveNtfToken st tknId
           verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
         Just s@NtfSubData {tokenId = subTknId} ->
           if subTknId == tknId
             then do
-              -- TODO move active token check here to differentiate error
               t_ <- atomically $ getActiveNtfToken st subTknId
               verifyToken' t_ $ verifiedSubCmd s c
             else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+    NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId
     NtfCmd SSubscription c -> do
       s_ <- atomically $ getNtfSubscription st entId
       case s_ of
         Just s@NtfSubData {tokenId = subTknId} -> do
-          -- TODO move active token check here to differentiate error
           t_ <- atomically $ getActiveNtfToken st subTknId
           verifyToken' t_ $ verifiedSubCmd s c
         _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
   where
     verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
     verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
-    verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> m VerificationResult
+    verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> M VerificationResult
     verifyToken t_ positiveVerificationResult =
       pure $ case t_ of
         Just t@NtfTknData {tknVerifyKey} ->
@@ -322,17 +391,17 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
             then positiveVerificationResult t
             else VRFailed
         _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    verifyToken' :: Maybe NtfTknData -> VerificationResult -> m VerificationResult
+    verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult
     verifyToken' t_ = verifyToken t_ . const
 
-client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
+client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
 client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: NtfRequest -> m (Transmission NtfResponse)
+    processCommand :: NtfRequest -> M (Transmission NtfResponse)
     processCommand = \case
       NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
         logDebug "TNEW - new token"
@@ -345,6 +414,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         atomically $ addNtfToken st tknId tkn
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
         withNtfLog (`logCreateToken` tkn)
+        incNtfStat tknCreated
         pure (corrId, "", NRTknId tknId srvDhPubKey)
       NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
@@ -366,6 +436,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               tIds <- atomically $ removeInactiveTokenRegistrations st tkn
               forM_ tIds cancelInvervalNotifications
               withNtfLog $ \s -> logTokenStatus s tknId NTActive
+              incNtfStat tknVerified
               pure NROk
             | otherwise -> do
               logDebug "TVFY - incorrect code or token status"
@@ -384,6 +455,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               addNtfToken st tknId tkn'
               writeTBQueue pushQ (tkn', PNVerification regCode)
             withNtfLog $ \s -> logUpdateToken s tknId token' regCode
+            incNtfStat tknDeleted
+            incNtfStat tknCreated
             pure NROk
           TDEL -> do
             logDebug "TDEL"
@@ -393,6 +466,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             cancelInvervalNotifications tknId
             withNtfLog (`logDeleteToken` tknId)
+            incNtfStat tknDeleted
             pure NROk
           TCRN 0 -> do
             logDebug "TCRN 0"
@@ -432,13 +506,14 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
             _ -> pure $ NRErr AUTH
         withNtfLog (`logCreateSubscription` sub)
+        incNtfStat subCreated
         pure (corrId, "", resp)
       NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         status <- readTVarIO subStatus
         (corrId,subId,) <$> case cmd of
           SNEW (NewNtfSub _ _ notifierKey) -> do
             logDebug "SNEW - existing subscription"
-            -- TODO retry if subscription failed, if pending or AUTH do nothing
+            -- possible improvement: retry if subscription failed, if pending or AUTH do nothing
             pure $
               if notifierKey == registeredNKey
                 then NRSubId subId
@@ -452,20 +527,52 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             atomically $ deleteNtfSubscription st subId
             atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             withNtfLog (`logDeleteSubscription` subId)
+            incNtfStat subDeleted
             pure NROk
           PING -> pure NRPong
-    getId :: m NtfEntityId
+      NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
+    getId :: M NtfEntityId
     getId = getRandomBytes =<< asks (subIdBytes . config)
-    getRegCode :: m NtfRegCode
+    getRegCode :: M NtfRegCode
     getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config))
-    getRandomBytes :: Int -> m ByteString
+    getRandomBytes :: Int -> M ByteString
     getRandomBytes n = do
       gVar <- asks idsDrg
       atomically (C.pseudoRandomBytes n gVar)
-    cancelInvervalNotifications :: NtfTokenId -> m ()
+    cancelInvervalNotifications :: NtfTokenId -> M ()
     cancelInvervalNotifications tknId =
       atomically (TM.lookupDelete tknId intervalNotifiers)
         >>= mapM_ (uninterruptibleCancel . action)
 
-withNtfLog :: (MonadUnliftIO m, MonadReader NtfEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
+withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withNtfLog action = liftIO . mapM_ action =<< asks storeLog
+
+incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
+incNtfStat statSel = do
+  stats <- asks serverStats
+  atomically $ modifyTVar' (statSel stats) (+ 1)
+
+saveServerStats :: M ()
+saveServerStats =
+  asks (serverStatsBackupFile . config)
+    >>= mapM_ (\f -> asks serverStats >>= atomically . getNtfServerStatsData >>= liftIO . saveStats f)
+  where
+    saveStats f stats = do
+      logInfo $ "saving server stats to file " <> T.pack f
+      B.writeFile f $ strEncode stats
+      logInfo "server stats saved"
+
+restoreServerStats :: M ()
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
+  where
+    restoreStats f = whenM (doesFileExist f) $ do
+      logInfo $ "restoring server stats from file " <> T.pack f
+      liftIO (strDecode <$> B.readFile f) >>= \case
+        Right d -> do
+          s <- asks serverStats
+          atomically $ setNtfServerStats s d
+          renameFile f $ f <> ".bak"
+          logInfo "server stats restored"
+        Left e -> do
+          logInfo $ "error restoring server stats: " <> T.pack e
+          liftIO exitFailure

src/Simplex/Messaging/Notifications/Server/Env.hs

@@ -11,6 +11,7 @@ import Control.Concurrent.Async (Async)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Word (Word16)
 import Data.X509.Validation (Fingerprint (..))
@@ -21,6 +22,7 @@ import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
@@ -48,7 +50,13 @@ data NtfServerConfig = NtfServerConfig
     -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath
+    certificateFile :: FilePath,
+    -- stats config - see SMP server config
+    logStatsInterval :: Maybe Int,
+    logStatsStartTime :: Int,
+    serverStatsLogFile :: FilePath,
+    serverStatsBackupFile :: Maybe FilePath,
+    logTLSErrors :: Bool
   }
 
 defaultInactiveClientExpiration :: ExpirationConfig
@@ -67,7 +75,8 @@ data NtfEnv = NtfEnv
     idsDrg :: TVar ChaChaDRG,
     serverIdentity :: C.KeyHash,
     tlsServerParams :: T.ServerParams,
-    serverIdentity :: C.KeyHash
+    serverIdentity :: C.KeyHash,
+    serverStats :: NtfServerStats
   }
 
 newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
@@ -79,7 +88,8 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
   pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
-  pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
+  serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
+  pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 data NtfSubscriber = NtfSubscriber
   { smpSubscribers :: TMap SMPServer SMPSubscriber,
@@ -138,6 +148,7 @@ getPushClient s@NtfPushServer {pushClients} pp =
 data NtfRequest
   = NtfReqNew CorrId ANewNtfEntity
   | forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
+  | NtfReqPing CorrId NtfEntityId
 
 data NtfServerClient = NtfServerClient
   { rcvQ :: TBQueue NtfRequest,

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -0,0 +1,174 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Simplex.Messaging.Notifications.Server.Main where
+
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Ini (lookupValue, readIniFile)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Network.Socket (HostName)
+import Options.Applicative
+import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Server (runNtfServer)
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
+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)
+
+ntfServerVersion :: String
+ntfServerVersion = "1.3.0"
+
+ntfServerCLI :: FilePath -> FilePath -> IO ()
+ntfServerCLI cfgPath logPath =
+  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 "ntf-server.ini"
+    serverVersion = "SMP notifications server v" <> ntfServerVersion
+    defaultServerPort = "443"
+    executableName = "ntf-server"
+    storeLogFilePath = combine logPath "ntf-server-store.log"
+    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = 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 (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing
+      writeFile iniFile $ iniFileContent host
+      putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
+      warnCAPrivateKeyFile cfgPath x509cfg
+      printServiceInfo serverVersion srv
+      where
+        iniFileContent host =
+          "[STORE_LOG]\n\
+          \# The server uses STM memory for persistence,\n\
+          \# that will be lost on restart (e.g., as with redis).\n\
+          \# This option enables saving memory to append only log,\n\
+          \# and restoring it when the server is started.\n\
+          \# Log is compacted on start (deleted objects are removed).\n"
+            <> ("enable: " <> onOff enableStoreLog <> "\n\n")
+            <> "log_stats: off\n\n\
+               \[TRANSPORT]\n\
+               \# host is only used to print server address on start\n"
+            <> ("host: " <> host <> "\n")
+            <> ("port: " <> defaultServerPort <> "\n")
+            <> "log_tls_errors: off\n\
+               \websockets: off\n"
+    runServer ini = do
+      hSetBuffering stdout LineBuffering
+      hSetBuffering stderr LineBuffering
+      fp <- checkSavedFingerprint cfgPath defaultX509Config
+      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
+          port = T.unpack $ strictIni "TRANSPORT" "port" ini
+          cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
+      printServiceInfo serverVersion srv
+      printServerConfig transports storeLogFile
+      runNtfServer cfg
+      where
+        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+        logStats = settingIsOn "STORE_LOG" "log_stats" ini
+        c = combine cfgPath . ($ defaultX509Config)
+        serverConfig =
+          NtfServerConfig
+            { transports = iniTransports ini,
+              subIdBytes = 24,
+              regCodeBytes = 32,
+              clientQSize = 16,
+              subQSize = 64,
+              pushQSize = 128,
+              smpAgentCfg = defaultSMPClientAgentConfig,
+              apnsConfig = defaultAPNSPushClientConfig,
+              inactiveClientExpiration = Nothing,
+              storeLogFile = enableStoreLog $> storeLogFilePath,
+              resubscribeDelay = 50000, -- 50ms
+              caCertificateFile = c caCrtFile,
+              privateKeyFile = c serverKeyFile,
+              certificateFile = c serverCrtFile,
+              logStatsInterval = logStats $> 86400, -- seconds
+              logStatsStartTime = 0, -- seconds from 00:00 UTC
+              serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
+              serverStatsBackupFile = logStats $> combine logPath "ntf-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
+  }
+  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"
+          )

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

@@ -32,11 +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.Text.Encoding (decodeUtf8With)
 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
@@ -48,7 +49,9 @@ 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)
 import UnliftIO.STM
 
@@ -90,15 +93,15 @@ signedJWTToken pk (JWTToken hdr claims) = do
 
 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do
-  -- TODO this is specific to APNS key
+  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
   [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
   pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
 
 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
@@ -287,15 +293,15 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
   PNMessage pnMessageData ->
     encrypt (strEncode pnMessageData) $ \ntfData ->
       apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
-  PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
+  -- PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
   PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
   where
     encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
     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}
-    safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?'
+
+-- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
 
 apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
 apnsRequest c tkn ntf@APNSNotification {aps} = do
@@ -337,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
@@ -358,7 +365,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
         _ -> err status reason'
       | status == Just N.gone410 = throwError PPTokenInvalid
       | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
-      -- Just tooManyRequests429 -> TODO TooManyRequests - too many requests for the same token
+      -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
       | otherwise = err status reason'
     err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
     err s r = throwError $ PPResponseError s r

src/Simplex/Messaging/Notifications/Server/Stats.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Notifications.Server.Stats where
+
+import Control.Applicative (optional)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Char8 as B
+import Data.Time.Clock (UTCTime)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
+import Simplex.Messaging.Protocol (NotifierId)
+import Simplex.Messaging.Server.Stats
+import UnliftIO.STM
+
+data NtfServerStats = NtfServerStats
+  { fromTime :: TVar UTCTime,
+    tknCreated :: TVar Int,
+    tknVerified :: TVar Int,
+    tknDeleted :: TVar Int,
+    subCreated :: TVar Int,
+    subDeleted :: TVar Int,
+    ntfReceived :: TVar Int,
+    ntfDelivered :: TVar Int,
+    activeTokens :: PeriodStats NtfTokenId,
+    activeSubs :: PeriodStats NotifierId
+  }
+
+data NtfServerStatsData = NtfServerStatsData
+  { _fromTime :: UTCTime,
+    _tknCreated :: Int,
+    _tknVerified :: Int,
+    _tknDeleted :: Int,
+    _subCreated :: Int,
+    _subDeleted :: Int,
+    _ntfReceived :: Int,
+    _ntfDelivered :: Int,
+    _activeTokens :: PeriodStatsData NtfTokenId,
+    _activeSubs :: PeriodStatsData NotifierId
+  }
+
+newNtfServerStats :: UTCTime -> STM NtfServerStats
+newNtfServerStats ts = do
+  fromTime <- newTVar ts
+  tknCreated <- newTVar 0
+  tknVerified <- newTVar 0
+  tknDeleted <- newTVar 0
+  subCreated <- newTVar 0
+  subDeleted <- newTVar 0
+  ntfReceived <- newTVar 0
+  ntfDelivered <- newTVar 0
+  activeTokens <- newPeriodStats
+  activeSubs <- newPeriodStats
+  pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
+
+getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData
+getNtfServerStatsData s = do
+  _fromTime <- readTVar $ fromTime (s :: NtfServerStats)
+  _tknCreated <- readTVar $ tknCreated s
+  _tknVerified <- readTVar $ tknVerified s
+  _tknDeleted <- readTVar $ tknDeleted s
+  _subCreated <- readTVar $ subCreated s
+  _subDeleted <- readTVar $ subDeleted s
+  _ntfReceived <- readTVar $ ntfReceived s
+  _ntfDelivered <- readTVar $ ntfDelivered s
+  _activeTokens <- getPeriodStatsData $ activeTokens s
+  _activeSubs <- getPeriodStatsData $ activeSubs s
+  pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
+
+setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
+setNtfServerStats s d = do
+  writeTVar (fromTime (s :: NtfServerStats)) $! _fromTime (d :: NtfServerStatsData)
+  writeTVar (tknCreated s) $! _tknCreated d
+  writeTVar (tknVerified s) $! _tknVerified d
+  writeTVar (tknDeleted s) $! _tknDeleted d
+  writeTVar (subCreated s) $! _subCreated d
+  writeTVar (subDeleted s) $! _subDeleted d
+  writeTVar (ntfReceived s) $! _ntfReceived d
+  writeTVar (ntfDelivered s) $! _ntfDelivered d
+  setPeriodStats (activeTokens s) (_activeTokens d)
+  setPeriodStats (activeSubs s) (_activeSubs d)
+
+instance StrEncoding NtfServerStatsData where
+  strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =
+    B.unlines
+      [ "fromTime=" <> strEncode _fromTime,
+        "tknCreated=" <> strEncode _tknCreated,
+        "tknVerified=" <> strEncode _tknVerified,
+        "tknDeleted=" <> strEncode _tknDeleted,
+        "subCreated=" <> strEncode _subCreated,
+        "subDeleted=" <> strEncode _subDeleted,
+        "ntfReceived=" <> strEncode _ntfReceived,
+        "ntfDelivered=" <> strEncode _ntfDelivered,
+        "activeTokens:",
+        strEncode _activeTokens,
+        "activeSubs:",
+        strEncode _activeSubs
+      ]
+  strP = do
+    _fromTime <- "fromTime=" *> strP <* A.endOfLine
+    _tknCreated <- "tknCreated=" *> strP <* A.endOfLine
+    _tknVerified <- "tknVerified=" *> strP <* A.endOfLine
+    _tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
+    _subCreated <- "subCreated=" *> strP <* A.endOfLine
+    _subDeleted <- "subDeleted=" *> strP <* A.endOfLine
+    _ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
+    _ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
+    _ <- "activeTokens:" <* A.endOfLine
+    _activeTokens <- strP <* A.endOfLine
+    _ <- "activeSubs:" <* A.endOfLine
+    _activeSubs <- strP <* optional A.endOfLine
+    pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}

src/Simplex/Messaging/Notifications/Server/Store.hs

@@ -106,6 +106,7 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
       forM_ tIds $ \(regKey, tId') -> do
         TM.delete regKey tknRegs
         TM.delete tId' $ tokens st
+        void $ deleteTokenSubs st tId'
       pure $ map snd tIds
 
 removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
@@ -119,36 +120,28 @@ removeTokenRegistration st NtfTknData {ntfTknId = tId, token, tknVerifyKey} =
 
 deleteNtfToken :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
 deleteNtfToken st tknId = do
-  TM.lookupDelete tknId (tokens st)
-    >>= mapM_
-      ( \NtfTknData {token, tknVerifyKey} ->
-          TM.lookup token regs
-            >>= mapM_
-              ( \tIds -> do
-                  TM.delete (regKey tknVerifyKey) tIds
-                  whenM (TM.null tIds) $ TM.delete token regs
-              )
-      )
-
-  qs <-
-    TM.lookupDelete tknId (tokenSubscriptions st)
-      >>= mapM
-        ( readTVar
-            >=> mapM
-              ( \subId -> do
-                  TM.lookupDelete subId (subscriptions st)
-                    >>= mapM
-                      ( \NtfSubData {smpQueue} ->
-                          TM.delete smpQueue (subscriptionLookup st) $> smpQueue
-                      )
-              )
-              . S.toList
-        )
-  pure $ maybe [] catMaybes qs
+  void $
+    TM.lookupDelete tknId (tokens st) $>>= \NtfTknData {token, tknVerifyKey} ->
+      TM.lookup token regs $>>= \tIds ->
+        TM.delete (regKey tknVerifyKey) tIds
+          >> whenM (TM.null tIds) (TM.delete token regs) $> Just ()
+  deleteTokenSubs st tknId
   where
     regs = tokenRegistrations st
     regKey = C.toPubKey C.pubKeyBytes
 
+deleteTokenSubs :: NtfStore -> NtfTokenId -> STM [SMPQueueNtf]
+deleteTokenSubs st tknId = do
+  qs <-
+    TM.lookupDelete tknId (tokenSubscriptions st)
+      >>= mapM (readTVar >=> mapM deleteSub . S.toList)
+  pure $ maybe [] catMaybes qs
+  where
+    deleteSub subId = do
+      TM.lookupDelete subId (subscriptions st)
+        $>>= \NtfSubData {smpQueue} ->
+          TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue
+
 getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData)
 getNtfSubscription st subId =
   TM.lookup subId (subscriptions st)

src/Simplex/Messaging/Notifications/Transport.hs

@@ -69,4 +69,4 @@ ntfClientHandshake c keyHash ntfVRange = do
       Nothing -> throwError $ TEHandshake VERSION
 
 ntfTHandle :: Transport c => c -> THandle c
-ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}
+ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False}

src/Simplex/Messaging/Notifications/Types.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Messaging.Notifications.Types where
 
@@ -88,6 +87,7 @@ isDeleteNtfSubAction = \case
     NSACreate -> False
     NSACheck -> False
     NSADelete -> True
+    NSARotate -> True
   NtfSubSMPAction a -> case a of
     NSASmpKey -> False
     NSASmpDelete -> True
@@ -98,6 +98,7 @@ data NtfSubNTFAction
   = NSACreate
   | NSACheck
   | NSADelete
+  | NSARotate
   deriving (Show)
 
 instance Encoding NtfSubNTFAction where
@@ -105,11 +106,13 @@ instance Encoding NtfSubNTFAction where
     NSACreate -> "N"
     NSACheck -> "C"
     NSADelete -> "D"
+    NSARotate -> "R"
   smpP =
     A.anyChar >>= \case
       'N' -> pure NSACreate
       'C' -> pure NSACheck
       'D' -> pure NSADelete
+      'R' -> pure NSARotate
       _ -> fail "bad NtfSubNTFAction"
 
 instance FromField NtfSubNTFAction where fromField = blobFieldDecoder smpDecode

src/Simplex/Messaging/Parsers.hs

@@ -118,6 +118,7 @@ taggedObjectJSON :: (String -> String) -> J.Options
 taggedObjectJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.TaggedObject "type" "data",
+      J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
       J.allNullaryToStringTag = False,
       J.nullaryToObject = True,
@@ -128,6 +129,7 @@ singleFieldJSON :: (String -> String) -> J.Options
 singleFieldJSON tagModifier =
   J.defaultOptions
     { J.sumEncoding = J.ObjectWithSingleField,
+      J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
       J.allNullaryToStringTag = False,
       J.nullaryToObject = True,

src/Simplex/Messaging/Protocol.hs

@@ -4,9 +4,11 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
@@ -18,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
@@ -37,8 +38,7 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Protocol
   ( -- * SMP protocol parameters
-    smpClientVersion,
-    smpClientVRange,
+    supportedSMPClientVRange,
     maxMessageLength,
     e2eEncConfirmationLength,
     e2eEncMessageLength,
@@ -52,6 +52,7 @@ module Simplex.Messaging.Protocol
     SParty (..),
     PartyI (..),
     QueueIdsKeys (..),
+    ProtocolErrorType (..),
     ErrorType (..),
     CommandError (..),
     Transmission,
@@ -64,14 +65,23 @@ module Simplex.Messaging.Protocol
     PrivHeader (..),
     Protocol (..),
     ProtocolType (..),
+    AProtocolType (..),
+    ProtocolTypeI (..),
     ProtocolServer (..),
     ProtoServer,
     SMPServer,
     pattern SMPServer,
+    SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    XFTPServer,
+    pattern XFTPServer,
+    XFTPServerWithAuth,
+    ProtoServerWithAuth (..),
+    BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
+    EntityId,
     QueueId,
     RecipientId,
     SenderId,
@@ -110,10 +120,20 @@ module Simplex.Messaging.Protocol
     _smpP,
     encodeRcvMsgBody,
     clientRcvMsgBodyP,
+    legacyEncodeServer,
+    legacyServerP,
+    legacyStrEncodeServer,
+    sameSrvAddr,
+    sameSrvAddr',
+    noAuthSrv,
 
     -- * TCP transport functions
     tPut,
     tGet,
+    tParse,
+    tDecodeParseValidate,
+    tEncode,
+    tEncodeBatch,
 
     -- * exports for tests
     CommandTag (..),
@@ -123,14 +143,18 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad.Except
-import Data.Aeson (ToJSON (..))
+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.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Char (isPrint, isSpace)
+import Data.Functor (($>))
 import Data.Kind
-import Data.Maybe (isNothing)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
+import Data.Maybe (isJust, isNothing)
 import Data.String
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
@@ -143,15 +167,16 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
-smpClientVersion :: Version
-smpClientVersion = 1
+currentSMPClientVersion :: Version
+currentSMPClientVersion = 2
 
-smpClientVRange :: VersionRange
-smpClientVRange = mkVersionRange 1 smpClientVersion
+supportedSMPClientVRange :: VersionRange
+supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
 
 maxMessageLength :: Int
 maxMessageLength = 16088
@@ -203,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
 
@@ -241,7 +266,7 @@ type EntityId = ByteString
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
   -- SMP recipient commands
-  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
+  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> Command Recipient
   SUB :: Command Recipient
   KEY :: SndPublicVerifyKey -> Command Recipient
   NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
@@ -288,12 +313,17 @@ data RcvMessage = RcvMessage
   deriving (Eq, Show)
 
 -- | received message without server/recipient encryption
-data Message = Message
-  { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: C.MaxLenBS MaxMessageLen
-  }
+data Message
+  = Message
+      { msgId :: MsgId,
+        msgTs :: SystemTime,
+        msgFlags :: MsgFlags,
+        msgBody :: C.MaxLenBS MaxMessageLen
+      }
+  | MessageQuota
+      { msgId :: MsgId,
+        msgTs :: SystemTime
+      }
 
 instance StrEncoding RcvMessage where
   strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} =
@@ -313,44 +343,72 @@ instance StrEncoding RcvMessage where
 newtype EncRcvMsgBody = EncRcvMsgBody ByteString
   deriving (Eq, Show)
 
-data RcvMsgBody = RcvMsgBody
-  { msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: C.MaxLenBS MaxMessageLen
-  }
+data RcvMsgBody
+  = RcvMsgBody
+      { msgTs :: SystemTime,
+        msgFlags :: MsgFlags,
+        msgBody :: C.MaxLenBS MaxMessageLen
+      }
+  | RcvMsgQuota
+      { msgTs :: SystemTime
+      }
+
+msgQuotaTag :: ByteString
+msgQuotaTag = "QUOTA"
 
 encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
-encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody} =
-  let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
-   in C.appendMaxLenBS rcvMeta msgBody
+encodeRcvMsgBody = \case
+  RcvMsgBody {msgTs, msgFlags, msgBody} ->
+    let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
+     in C.appendMaxLenBS rcvMeta msgBody
+  RcvMsgQuota {msgTs} ->
+    C.unsafeMaxLenBS $ msgQuotaTag <> " " <> smpEncode msgTs
 
-data ClientRcvMsgBody = ClientRcvMsgBody
-  { msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
-    msgBody :: ByteString
-  }
+data ClientRcvMsgBody
+  = ClientRcvMsgBody
+      { msgTs :: SystemTime,
+        msgFlags :: MsgFlags,
+        msgBody :: ByteString
+      }
+  | ClientRcvMsgQuota
+      { msgTs :: SystemTime
+      }
 
 clientRcvMsgBodyP :: Parser ClientRcvMsgBody
-clientRcvMsgBodyP = do
-  msgTs <- smpP
-  msgFlags <- smpP
-  Tail msgBody <- _smpP
-  pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}
+clientRcvMsgBodyP = msgQuotaP <|> msgBodyP
+  where
+    msgQuotaP = A.string msgQuotaTag *> (ClientRcvMsgQuota <$> _smpP)
+    msgBodyP = do
+      msgTs <- smpP
+      msgFlags <- smpP
+      Tail msgBody <- _smpP
+      pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}
 
 instance StrEncoding Message where
-  strEncode Message {msgId, msgTs, msgFlags, msgBody} =
-    B.unwords
-      [ strEncode msgId,
-        strEncode msgTs,
-        "flags=" <> strEncode msgFlags,
-        strEncode msgBody
-      ]
+  strEncode = \case
+    Message {msgId, msgTs, msgFlags, msgBody} ->
+      B.unwords
+        [ strEncode msgId,
+          strEncode msgTs,
+          "flags=" <> strEncode msgFlags,
+          strEncode msgBody
+        ]
+    MessageQuota {msgId, msgTs} ->
+      B.unwords
+        [ strEncode msgId,
+          strEncode msgTs,
+          "quota"
+        ]
   strP = do
     msgId <- strP_
     msgTs <- strP_
-    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
-    msgBody <- strP
-    pure Message {msgId, msgTs, msgFlags, msgBody}
+    msgQuotaP msgId msgTs <|> msgP msgId msgTs
+    where
+      msgQuotaP msgId msgTs = "quota" $> MessageQuota {msgId, msgTs}
+      msgP msgId msgTs = do
+        msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
+        msgBody <- strP
+        pure Message {msgId, msgTs, msgFlags, msgBody}
 
 type EncNMsgMeta = ByteString
 
@@ -362,7 +420,9 @@ data SMPMsgMeta = SMPMsgMeta
   deriving (Show)
 
 rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
-rcvMessageMeta msgId ClientRcvMsgBody {msgTs, msgFlags} = SMPMsgMeta {msgId, msgTs, msgFlags}
+rcvMessageMeta msgId = \case
+  ClientRcvMsgBody {msgTs, msgFlags} -> SMPMsgMeta {msgId, msgTs, msgFlags}
+  ClientRcvMsgQuota {msgTs} -> SMPMsgMeta {msgId, msgTs, msgFlags = noMsgFlags}
 
 data NMsgMeta = NMsgMeta
   { msgId :: MsgId,
@@ -552,34 +612,56 @@ instance Encoding ClientMessage where
 
 type SMPServer = ProtocolServer 'PSMP
 
-pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
+pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
 pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
 
 {-# COMPLETE SMPServer #-}
 
+type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
+
 type NtfServer = ProtocolServer 'PNTF
 
-pattern NtfServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
+pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
 pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
 
 {-# COMPLETE NtfServer #-}
 
-data ProtocolType = PSMP | PNTF
+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' #-}
+
+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 | PXFTP
   deriving (Eq, Ord, Show)
 
 instance StrEncoding ProtocolType where
   strEncode = \case
     PSMP -> "smp"
     PNTF -> "ntf"
+    PXFTP -> "xftp"
   strP =
-    A.takeTill (== ':') >>= \case
+    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)
 
@@ -589,20 +671,28 @@ deriving instance Show (SProtocolType p)
 
 data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
 
+deriving instance Show AProtocolType
+
+instance Eq AProtocolType where
+  AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
+
 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
@@ -612,6 +702,10 @@ instance StrEncoding AProtocolType where
   strEncode (AProtocolType p) = strEncode p
   strP = aProtocolType <$> strP
 
+instance ToJSON AProtocolType where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
 checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
 checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
   Just Refl -> Right p
@@ -624,10 +718,12 @@ 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,
-    host :: HostName,
+    host :: NonEmpty TransportHost,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
@@ -645,17 +741,90 @@ instance ProtocolTypeI p => Encoding (ProtocolServer p) where
 
 instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
   strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncode scheme <> "://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
-  strP = do
-    scheme <- strP <* "://"
-    keyHash <- strP <* A.char '@'
-    SrvLoc host port <- strP
-    pure ProtocolServer {scheme, host, port, keyHash}
+    strEncodeServer scheme (strEncode host) port keyHash Nothing
+  strP =
+    serverStrP >>= \case
+      (srv, Nothing) -> pure srv
+      _ -> fail "ProtocolServer with basic auth not allowed"
 
 instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance ProtocolTypeI p => FromJSON (ProtocolServer p) where
+  parseJSON = strParseJSON "ProtocolServer"
+
+newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
+  deriving (Eq, Ord, Show)
+
+instance IsString BasicAuth where fromString = BasicAuth . B.pack
+
+instance Encoding BasicAuth where
+  smpEncode (BasicAuth s) = smpEncode s
+  smpP = basicAuth <$?> smpP
+
+instance StrEncoding BasicAuth where
+  strEncode (BasicAuth s) = s
+  strP = basicAuth <$?> A.takeWhile1 (/= '@')
+
+basicAuth :: ByteString -> Either String BasicAuth
+basicAuth s
+  | B.all valid s = Right $ BasicAuth s
+  | otherwise = Left "invalid character in BasicAuth"
+  where
+    valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'
+
+data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer p, serverBasicAuth :: Maybe BasicAuth}
+  deriving (Eq, Ord, Show)
+
+instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
+  fromString = parseString strDecode
+
+instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
+  strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
+    strEncodeServer scheme (strEncode host) port keyHash auth_
+  strP = uncurry ProtoServerWithAuth <$> serverStrP
+
+instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
+  parseJSON = strParseJSON "ProtoServerWithAuth"
+
+noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
+noAuthSrv srv = ProtoServerWithAuth srv Nothing
+
+legacyEncodeServer :: ProtocolServer p -> ByteString
+legacyEncodeServer ProtocolServer {host, port, keyHash} =
+  smpEncode (L.head host, port, keyHash)
+
+legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
+legacyServerP = do
+  (h, port, keyHash) <- smpP
+  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}
+
+legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
+legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
+  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
+
+strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
+strEncodeServer scheme host port keyHash auth_ =
+  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
+  where
+    portStr = B.pack $ if null port then "" else ':' : port
+
+serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
+serverStrP = do
+  scheme <- strP <* "://"
+  keyHash <- strP
+  auth_ <- optional $ A.char ':' *> strP
+  TransportHosts host <- A.char '@' *> strP
+  port <- portP <|> pure ""
+  pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
+  where
+    portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
 
@@ -664,7 +833,7 @@ instance StrEncoding SrvLoc where
   strP = SrvLoc <$> host <*> (port <|> pure "")
     where
       host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
+      port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
 -- | Transmission correlation ID.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
@@ -729,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
@@ -748,7 +919,7 @@ data ErrorType
   | -- | internal server error
     INTERNAL
   | -- | used internally, never returned by the server (to be removed)
-    DUPLICATE_ -- TODO remove, not part of SMP protocol
+    DUPLICATE_ -- not part of SMP protocol, used internally
   deriving (Eq, Generic, Read, Show)
 
 instance ToJSON ErrorType where
@@ -799,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
@@ -817,16 +988,23 @@ 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 -> e (NEW_, ' ', rKey, dhKey)
+    NEW rKey dhKey auth_ -> case auth_ of
+      Just auth
+        | v >= 5 -> new <> e ('A', auth)
+        | otherwise -> new
+      _ -> new
+      where
+        new = e (NEW_, ' ', rKey, dhKey)
     SUB -> e SUB_
     KEY k -> e (KEY_, ' ', k)
     NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
@@ -848,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 {}
@@ -867,14 +1048,18 @@ 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
 
   protocolP v = \case
     CT SRecipient tag ->
       Cmd SRecipient <$> case tag of
-        NEW_ -> NEW <$> _smpP <*> smpP
+        NEW_
+          | v >= 5 -> new <*> optional (A.char 'A' *> smpP)
+          | otherwise -> new <*> pure Nothing
+          where
+            new = NEW <$> _smpP <*> smpP
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
         NKEY_ -> NKEY <$> _smpP <*> smpP
@@ -888,14 +1073,17 @@ instance ProtocolEncoding Cmd where
     CT SSender tag ->
       Cmd SSender <$> case tag of
         SEND_
-          | v == 1 -> SEND <$> pure noMsgFlags <*> (unTail <$> _smpP)
+          | v == 1 -> SEND noMsgFlags <$> (unTail <$> _smpP)
           | otherwise -> SEND <$> _smpP <*> (unTail <$> _smpP)
         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)
@@ -930,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
@@ -948,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
@@ -961,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
@@ -1010,34 +1203,80 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
-tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
+tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
+tPut th trs
+  | batch th = tPutBatch [] $ L.map tEncode trs
+  | otherwise = forM (L.toList trs) $ tPutLog . tEncode
+  where
+    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 (tEncodeBatch n s)
+      let rs' = rs <> r
+      case ts_ of
+        Just ts' -> tPutBatch rs' ts'
+        _ -> pure rs'
+    largeMsg = putStrLn "tPut error: large message" >> pure [Left TELargeMsg]
+    tPutLog s = do
+      r <- tPutBlock th s
+      case r of
+        Left e -> putStrLn ("tPut error: " <> show e)
+        _ -> pure ()
+      pure r
+    encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
+    encodeBatch n s ts@(t :| ts_)
+      | n == 255 = (n, s, Just ts)
+      | otherwise =
+        let s' = s <> smpEncode (Large t)
+            n' = n + 1
+         in if B.length s' > blockSize th - 1 -- one byte is reserved for the number of messages in the batch
+              then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
+              else case L.nonEmpty ts_ of
+                Just ts' -> encodeBatch n' s' ts'
+                _ -> (n', s', Nothing)
 
-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 (Either TransportError RawTransmission)
-tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
+tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
+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
+    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 (SignedTransmission cmd)
-tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= 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

@@ -6,8 +6,8 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -41,19 +41,17 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
 import Data.Bifunctor (first)
+import Data.ByteString.Base64 (encode)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
+import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.List (intercalate)
+import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing)
-import Data.Set (Set)
-import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Calendar.Month.Compat (pattern MonthDay)
-import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
@@ -67,9 +65,9 @@ import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
+import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
+import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
@@ -78,6 +76,7 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
+import System.IO (hPutStrLn)
 import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
@@ -88,7 +87,7 @@ import UnliftIO.STM
 -- | Runs an SMP server using passed configuration.
 --
 -- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
-runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServerConfig -> m ()
+runSMPServer :: ServerConfig -> IO ()
 runSMPServer cfg = do
   started <- newEmptyTMVarIO
   runSMPServerBlocking started cfg
@@ -97,15 +96,16 @@ runSMPServer cfg = do
 --
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
-runSMPServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
+runSMPServerBlocking :: TMVar Bool -> ServerConfig -> IO ()
+runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started cfg)
 
-smpServer :: forall m. (MonadUnliftIO m, MonadReader Env m) => TMVar Bool -> m ()
-smpServer started = do
+type M a = ReaderT Env IO a
+
+smpServer :: TMVar Bool -> ServerConfig -> M ()
+smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
   s <- asks server
-  cfg@ServerConfig {transports} <- asks config
-  restoreServerStats
   restoreServerMessages
+  restoreServerStats
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
       serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
@@ -113,10 +113,10 @@ smpServer started = do
     )
     `finally` (withLog closeStoreLog >> saveServerMessages >> saveServerStats)
   where
-    runServer :: (ServiceName, ATransport) -> m ()
+    runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams (runClient t)
+      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)
 
     serverThread ::
       forall s.
@@ -124,12 +124,12 @@ smpServer started = do
       (Server -> TBQueue (QueueId, Client)) ->
       (Server -> TMap QueueId Client) ->
       (Client -> TMap QueueId s) ->
-      (s -> m ()) ->
-      m ()
+      (s -> IO ()) ->
+      M ()
     serverThread s subQ subs clientSubs unsub = forever $ do
       atomically updateSubscribers
         $>>= endPreviousSubscriptions
-        >>= mapM_ unsub
+        >>= liftIO . mapM_ unsub
       where
         updateSubscribers :: STM (Maybe (QueueId, Client))
         updateSubscribers = do
@@ -141,17 +141,17 @@ smpServer started = do
                     yes <- readTVar $ connected c'
                     pure $ if yes then Just (qId, c') else Nothing
           TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
-        endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
+        endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
         endPreviousSubscriptions (qId, c) = do
           void . forkIO . atomically $
-            writeTBQueue (sndQ c) (CorrId "", qId, END)
+            writeTBQueue (sndQ c) [(CorrId "", qId, END)]
           atomically $ TM.lookupDelete qId (clientSubs c)
 
-    expireMessagesThread_ :: ServerConfig -> [m ()]
+    expireMessagesThread_ :: ServerConfig -> [M ()]
     expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
     expireMessagesThread_ _ = []
 
-    expireMessages :: ExpirationConfig -> m ()
+    expireMessages :: ExpirationConfig -> M ()
     expireMessages expCfg = do
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
@@ -164,39 +164,57 @@ smpServer started = do
           atomically (getMsgQueue ms rId quota)
             >>= atomically . (`deleteExpiredMsgs` old)
 
-    serverStatsThread_ :: ServerConfig -> [m ()]
-    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime} =
-      [logServerStats logStatsStartTime interval]
+    serverStatsThread_ :: ServerConfig -> [M ()]
+    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
+      [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> m ()
-    logServerStats startAt logInterval = do
+    logServerStats :: Int -> Int -> FilePath -> M ()
+    logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      logInfo "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues"
+      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
       let interval = 1000000 * logInterval
-      forever $ do
-        ts <- liftIO getCurrentTime
-        fromTime' <- atomically $ swapTVar fromTime ts
-        qCreated' <- atomically $ swapTVar qCreated 0
-        qSecured' <- atomically $ swapTVar qSecured 0
-        qDeleted' <- atomically $ swapTVar qDeleted 0
-        msgSent' <- atomically $ swapTVar msgSent 0
-        msgRecv' <- atomically $ swapTVar msgRecv 0
-        let day = utctDay ts
-            (_, wDay) = mondayStartWeek day
-            MonthDay _ mDay = day
-        (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
-          atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
-        logInfo . T.pack $ intercalate "," [iso8601Show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show dayMsgQueues', weekMsgQueues', monthMsgQueues']
-        threadDelay interval
-      where
-        periodCount :: Int -> TVar (Set RecipientId) -> STM String
-        periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
-        periodCount _ _ = pure ""
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
+          ts <- getCurrentTime
+          fromTime' <- atomically $ swapTVar fromTime ts
+          qCreated' <- atomically $ swapTVar qCreated 0
+          qSecured' <- atomically $ swapTVar qSecured 0
+          qDeleted' <- atomically $ swapTVar qDeleted 0
+          msgSent' <- atomically $ swapTVar msgSent 0
+          msgRecv' <- atomically $ swapTVar msgRecv 0
+          ps <- atomically $ periodStatCounts activeQueues ts
+          msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
+          msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
+          psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
+          qCount' <- readTVarIO qCount
+          msgCount' <- readTVarIO msgCount
+          hPutStrLn h $
+            intercalate
+              ","
+              [ iso8601Show $ utctDay fromTime',
+                show qCreated',
+                show qSecured',
+                show qDeleted',
+                show msgSent',
+                show msgRecv',
+                dayCount ps,
+                weekCount ps,
+                monthCount ps,
+                show msgSentNtf',
+                show msgRecvNtf',
+                dayCount psNtf,
+                weekCount psNtf,
+                monthCount psNtf,
+                show qCount',
+                show msgCount'
+              ]
+          threadDelay interval
 
-    runClient :: Transport c => TProxy c -> c -> m ()
+    runClient :: Transport c => TProxy c -> c -> M ()
     runClient _ h = do
       kh <- asks serverIdentity
       smpVRange <- asks $ smpServerVRange . config
@@ -204,24 +222,24 @@ smpServer started = do
         Right th -> runClientTransport th
         Left _ -> pure ()
 
-runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
+runClientTransport :: Transport c => THandle c -> M ()
 runClientTransport th@THandle {thVersion, sessionId} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
   c <- atomically $ newClient q thVersion sessionId ts
   s <- asks server
   expCfg <- asks $ inactiveClientExpiration . config
-  raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
+  raceAny_ ([liftIO $ send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
     `finally` clientDisconnected c
   where
-    disconnectThread_ c (Just expCfg) = [disconnectTransport th c activeAt expCfg]
+    disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th c activeAt expCfg]
     disconnectThread_ _ _ = []
 
-clientDisconnected :: (MonadUnliftIO m, MonadReader Env m) => Client -> m ()
+clientDisconnected :: Client -> M ()
 clientDisconnected c@Client {subscriptions, connected} = do
   atomically $ writeTVar connected False
   subs <- readTVarIO subscriptions
-  mapM_ cancelSub subs
+  liftIO $ mapM_ cancelSub subs
   atomically $ writeTVar subscriptions M.empty
   cs <- asks $ subscribers . server
   atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
@@ -234,34 +252,43 @@ clientDisconnected c@Client {subscriptions, connected} = do
 sameClientSession :: Client -> Client -> Bool
 sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
 
-cancelSub :: MonadUnliftIO m => TVar Sub -> m ()
+cancelSub :: TVar Sub -> IO ()
 cancelSub sub =
   readTVarIO sub >>= \case
     Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
     _ -> return ()
 
-receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
+receive :: Transport c => THandle c -> Client -> M ()
 receive th Client {rcvQ, sndQ, activeAt} = forever $ do
-  (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
+  ts <- L.toList <$> liftIO (tGet th)
   atomically . writeTVar activeAt =<< liftIO getSystemTime
-  case cmdOrError of
-    Left e -> write sndQ (corrId, queueId, ERR e)
-    Right cmd -> do
-      verified <- verifyTransmission sig signed queueId cmd
-      if verified
-        then write rcvQ (corrId, queueId, cmd)
-        else write sndQ (corrId, queueId, ERR AUTH)
+  as <- partitionEithers <$> mapM cmdAction ts
+  write sndQ $ fst as
+  write rcvQ $ snd as
   where
-    write q t = atomically $ writeTBQueue q t
+    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)
+        Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
+          where
+            verified = \case
+              VRVerified qr -> Right (qr, (corrId, queueId, cmd))
+              VRFailed -> Left (corrId, queueId, ERR AUTH)
+    write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
-send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
+send :: Transport c => THandle c -> Client -> IO ()
 send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
-  t <- atomically $ readTBQueue sndQ
-  -- TODO the line below can return Left, but we ignore it and do not disconnect the client
-  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
+  ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
+  void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
   atomically . writeTVar activeAt =<< liftIO getSystemTime
+  where
+    tOrder :: Transmission BrokerMsg -> Int
+    tOrder (_, _, cmd) = case cmd of
+      MSG {} -> 0
+      _ -> 1
 
-disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
+disconnectTransport :: Transport c => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> IO ()
 disconnectTransport THandle {connection} c activeAt expCfg = do
   let interval = checkInterval expCfg * 1000000
   forever . liftIO $ do
@@ -270,23 +297,27 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
     ts <- readTVarIO $ activeAt c
     when (systemSeconds ts < old) $ closeConnection connection
 
-verifyTransmission ::
-  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
-verifyTransmission sig_ signed queueId cmd = do
+data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
+
+verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
+verifyTransmission sig_ signed queueId cmd =
   case cmd of
-    Cmd SRecipient (NEW k _) -> pure $ verifyCmdSignature sig_ signed k
+    Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
     Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
-    Cmd SSender PING -> pure True
+    Cmd SSender PING -> pure $ VRVerified Nothing
     Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
   where
-    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
     verifyCmd party f = do
       st <- asks queueStore
-      q <- atomically $ getQueue st party queueId
-      pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
+      q_ <- atomically $ getQueue st party queueId
+      pure $ case q_ of
+        Right q -> Just q `verified` f q
+        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
     verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
     verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
+    verified q cond = if cond then VRVerified q else VRFailed
 
 verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
 verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
@@ -317,28 +348,32 @@ client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server ->
 client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
-      >>= processCommand
+      >>= mapM processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
-    processCommand (corrId, queueId, cmd) = do
+    processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
+    processCommand (qr_, (corrId, queueId, cmd)) = do
       st <- asks queueStore
       case cmd of
         Cmd SSender command ->
           case command of
-            SEND flags msgBody -> sendMessage st flags msgBody
+            SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
             PING -> pure (corrId, "", PONG)
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
           case command of
-            NEW rKey dhKey ->
+            NEW rKey dhKey auth ->
               ifM
-                (asks $ allowNewQueues . config)
+                allowNew
                 (createQueue st rKey dhKey)
                 (pure (corrId, queueId, ERR AUTH))
-            SUB -> subscribeQueue st queueId
-            GET -> getMessage st
-            ACK msgId -> acknowledgeMsg st msgId
+              where
+                allowNew = do
+                  ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
+                  pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
+            SUB -> withQueue (`subscribeQueue` queueId)
+            GET -> withQueue getMessage
+            ACK msgId -> withQueue (`acknowledgeMsg` msgId)
             KEY sKey -> secureQueue_ st sKey
             NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
             NDEL -> deleteQueueNotifier_ st
@@ -346,7 +381,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             DEL -> delQueueAndMsgs st
       where
         createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg)
-        createQueue st recipientKey dhKey = do
+        createQueue st recipientKey dhKey = time "NEW" $ do
           (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
           let rcvDhSecret = C.dh' dhKey privDhKey
               qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
@@ -368,14 +403,16 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             addQueueRetry n qik qRec = do
               ids@(rId, _) <- getIds
               -- create QueueRec record with these ids and keys
-              atomically (addQueue st $ qRec ids) >>= \case
+              let qr = qRec ids
+              atomically (addQueue st qr) >>= \case
                 Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
                 Left e -> pure $ ERR e
                 Right _ -> do
                   withLog (`logCreateById` rId)
                   stats <- asks serverStats
-                  atomically $ modifyTVar (qCreated stats) (+ 1)
-                  subscribeQueue st rId $> IDS (qik ids)
+                  atomically $ modifyTVar' (qCreated stats) (+ 1)
+                  atomically $ modifyTVar' (qCount stats) (+ 1)
+                  subscribeQueue qr rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
             logCreateById s rId =
@@ -389,14 +426,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               liftM2 (,) (randomId n) (randomId n)
 
         secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
-        secureQueue_ st sKey = do
+        secureQueue_ st sKey = time "KEY" $ do
           withLog $ \s -> logSecureQueue s queueId sKey
           stats <- asks serverStats
-          atomically $ modifyTVar (qSecured stats) (+ 1)
+          atomically $ modifyTVar' (qSecured stats) (+ 1)
           atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
         addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
-        addQueueNotifier_ st notifierKey dhKey = do
+        addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do
           (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
           let rcvNtfDhSecret = C.dh' dhKey privDhKey
           (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
@@ -420,14 +457,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
 
         suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
         suspendQueue_ st = do
-          withLog (`logDeleteQueue` queueId)
+          withLog (`logSuspendQueue` queueId)
           okResp <$> atomically (suspendQueue st queueId)
 
-        subscribeQueue :: QueueStore -> RecipientId -> m (Transmission BrokerMsg)
-        subscribeQueue st rId =
+        subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
+        subscribeQueue qr rId = do
           atomically (TM.lookup rId subscriptions) >>= \case
             Nothing ->
-              atomically newSub >>= deliver
+              newSub >>= deliver
             Just sub ->
               readTVarIO sub >>= \case
                 Sub {subThread = ProhibitSub} ->
@@ -436,20 +473,20 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                 s ->
                   atomically (tryTakeTMVar $ delivered s) >> deliver sub
           where
-            newSub :: STM (TVar Sub)
-            newSub = do
+            newSub :: m (TVar Sub)
+            newSub = time "SUB newSub" . atomically $ do
               writeTBQueue subscribedQ (rId, clnt)
               sub <- newTVar =<< newSubscription NoSub
               TM.insert rId sub subscriptions
               pure sub
             deliver :: TVar Sub -> m (Transmission BrokerMsg)
             deliver sub = do
-              q <- getStoreMsgQueue rId
+              q <- getStoreMsgQueue "SUB" rId
               msg_ <- atomically $ tryPeekMsg q
-              deliverMessage st rId sub q msg_
+              deliverMessage "SUB" qr rId sub q msg_
 
-        getMessage :: QueueStore -> m (Transmission BrokerMsg)
-        getMessage st =
+        getMessage :: QueueRec -> m (Transmission BrokerMsg)
+        getMessage qr = time "GET" $ do
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= getMessage_
@@ -468,8 +505,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               TM.insert queueId sub subscriptions
               pure s
             getMessage_ :: Sub -> m (Transmission BrokerMsg)
-            getMessage_ s = withRcvQueue st queueId $ \qr -> do
-              q <- getStoreMsgQueue queueId
+            getMessage_ s = do
+              q <- getStoreMsgQueue "GET" queueId
               atomically $
                 tryPeekMsg q >>= \case
                   Just msg ->
@@ -477,36 +514,33 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                      in setDelivered s msg $> (corrId, queueId, MSG encMsg)
                   _ -> pure (corrId, queueId, OK)
 
-        withRcvQueue :: QueueStore -> RecipientId -> (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
-        withRcvQueue st rId action =
-          atomically (getQueue st SRecipient rId) >>= \case
-            Left e -> pure (corrId, rId, ERR e)
-            Right qr -> action qr
+        withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
+        withQueue action = maybe (pure $ err AUTH) action qr_
 
         subscribeNotifications :: m (Transmission BrokerMsg)
-        subscribeNotifications = atomically $ do
+        subscribeNotifications = time "NSUB" . atomically $ do
           unlessM (TM.member queueId ntfSubscriptions) $ do
             writeTBQueue ntfSubscribedQ (queueId, clnt)
             TM.insert queueId () ntfSubscriptions
           pure ok
 
-        acknowledgeMsg :: QueueStore -> MsgId -> m (Transmission BrokerMsg)
-        acknowledgeMsg st msgId = do
+        acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
+        acknowledgeMsg qr msgId = time "ACK" $ do
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing -> pure $ err NO_MSG
             Just sub ->
               atomically (getDelivered sub) >>= \case
                 Just s -> do
-                  q <- getStoreMsgQueue queueId
+                  q <- getStoreMsgQueue "ACK" queueId
                   case s of
                     Sub {subThread = ProhibitSub} -> do
-                      msgDeleted <- atomically $ tryDelMsg q msgId
-                      when msgDeleted updateStats
+                      deletedMsg_ <- atomically $ tryDelMsg q msgId
+                      mapM_ updateStats deletedMsg_
                       pure ok
                     _ -> do
-                      (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
-                      when msgDeleted updateStats
-                      deliverMessage st queueId sub q msg_
+                      (deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId
+                      mapM_ updateStats deletedMsg_
+                      deliverMessage "ACK" qr queueId sub q msg_
                 _ -> pure $ err NO_MSG
           where
             getDelivered :: TVar Sub -> STM (Maybe Sub)
@@ -516,117 +550,127 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                 if msgId == msgId' || B.null msgId
                   then pure $ Just s
                   else putTMVar delivered msgId' $> Nothing
-            updateStats :: m ()
-            updateStats = do
-              stats <- asks serverStats
-              atomically $ modifyTVar (msgRecv stats) (+ 1)
-              atomically $ updateActiveQueues stats queueId
+            updateStats :: Message -> m ()
+            updateStats = \case
+              MessageQuota {} -> pure ()
+              Message {msgFlags} -> do
+                stats <- asks serverStats
+                atomically $ modifyTVar' (msgRecv stats) (+ 1)
+                atomically $ modifyTVar' (msgCount stats) (+ 1)
+                atomically $ updatePeriodStats (activeQueues stats) queueId
+                when (notification msgFlags) $ do
+                  atomically $ modifyTVar' (msgRecvNtf stats) (+ 1)
+                  atomically $ updatePeriodStats (activeQueuesNtf stats) queueId
 
-        updateActiveQueues :: ServerStats -> RecipientId -> STM ()
-        updateActiveQueues stats qId = do
-          updatePeriod dayMsgQueues
-          updatePeriod weekMsgQueues
-          updatePeriod monthMsgQueues
-          where
-            updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
-
-        sendMessage :: QueueStore -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
-        sendMessage st msgFlags msgBody
+        sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
+        sendMessage qr msgFlags msgBody
           | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
-          | otherwise = do
-            qr <- atomically $ getQueue st SSender queueId
-            either (return . err) storeMessage qr
-          where
-            storeMessage :: QueueRec -> m (Transmission BrokerMsg)
-            storeMessage qr = case status qr of
-              QueueOff -> return $ err AUTH
-              QueueActive ->
-                mapM mkMessage (C.maxLenBS msgBody) >>= \case
-                  Left _ -> pure $ err LARGE_MSG
-                  Right msg -> do
-                    ms <- asks msgStore
-                    ServerConfig {messageExpiration, msgQueueQuota} <- asks config
-                    old <- liftIO $ mapM expireBeforeEpoch messageExpiration
-                    ntfNonceDrg <- asks idsDrg
-                    resp@(_, _, sent) <- atomically $ do
-                      q <- getMsgQueue ms (recipientId qr) msgQueueQuota
-                      mapM_ (deleteExpiredMsgs q) old
-                      ifM (isFull q) (pure $ err QUOTA) $ do
-                        when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
-                        writeMsg q msg
-                        pure ok
-                    when (sent == OK) $ do
+          | otherwise = case status qr of
+            QueueOff -> return $ err AUTH
+            QueueActive ->
+              case C.maxLenBS msgBody of
+                Left _ -> pure $ err LARGE_MSG
+                Right body -> do
+                  msg_ <- time "SEND" $ do
+                    q <- getStoreMsgQueue "SEND" $ recipientId qr
+                    expireMessages q
+                    atomically . writeMsg q =<< mkMessage body
+                  case msg_ of
+                    Nothing -> pure $ err QUOTA
+                    Just msg -> time "SEND ok" $ do
                       stats <- asks serverStats
-                      atomically $ modifyTVar (msgSent stats) (+ 1)
-                      atomically $ updateActiveQueues stats $ recipientId qr
-                    pure resp
-              where
-                mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
-                mkMessage body = do
-                  msgId <- randomId =<< asks (msgIdBytes . config)
-                  msgTs <- liftIO getSystemTime
-                  pure $ Message msgId msgTs msgFlags body
+                      when (notification msgFlags) $ do
+                        atomically . trySendNotification msg =<< asks idsDrg
+                        atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
+                        atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
+                      atomically $ modifyTVar' (msgSent stats) (+ 1)
+                      atomically $ modifyTVar' (msgCount stats) (subtract 1)
+                      atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
+                      pure ok
+          where
+            mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
+            mkMessage body = do
+              msgId <- randomId =<< asks (msgIdBytes . config)
+              msgTs <- liftIO getSystemTime
+              pure $ Message msgId msgTs msgFlags body
 
-                trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
-                trySendNotification msg ntfNonceDrg =
-                  forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
-                    mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
+            expireMessages :: MsgQueue -> m ()
+            expireMessages q = do
+              msgExp <- asks $ messageExpiration . config
+              old <- liftIO $ mapM expireBeforeEpoch msgExp
+              atomically $ mapM_ (deleteExpiredMsgs q) old
 
-                writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
-                writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
-                  unlessM (isFullTBQueue sndQ) $ do
-                    (nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
-                    writeTBQueue q (CorrId "", nId, NMSG nmsgNonce encNMsgMeta)
+            trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
+            trySendNotification msg ntfNonceDrg =
+              forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
+                mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
 
-                mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
-                mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
-                  cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
-                  let msgMeta = NMsgMeta {msgId, msgTs}
-                      encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
-                  pure . (cbNonce,) $ fromRight "" encNMsgMeta
+            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
+            writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
+              unlessM (isFullTBQueue q) $ case msg of
+                Message {msgId, msgTs} -> do
+                  (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
+                  writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
+                _ -> pure ()
 
-        deliverMessage :: QueueStore -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
-        deliverMessage st rId sub q msg_ = withRcvQueue st rId $ \qr -> do
+            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
+            mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do
+              cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
+              let msgMeta = NMsgMeta {msgId, msgTs}
+                  encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
+              pure . (cbNonce,) $ fromRight "" encNMsgMeta
+
+        deliverMessage :: T.Text -> QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
+        deliverMessage name qr rId sub q msg_ = time (name <> " deliver") $ do
           readTVarIO sub >>= \case
             s@Sub {subThread = NoSub} ->
               case msg_ of
                 Just msg ->
                   let encMsg = encryptMsg qr msg
                    in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
-                _ -> forkSub qr $> ok
+                _ -> forkSub $> ok
             _ -> pure ok
           where
-            forkSub :: QueueRec -> m ()
-            forkSub qr = do
-              atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
+            forkSub :: m ()
+            forkSub = do
+              atomically . modifyTVar' sub $ \s -> s {subThread = SubPending}
               t <- mkWeakThreadId =<< forkIO subscriber
-              atomically . modifyTVar sub $ \case
+              atomically . modifyTVar' sub $ \case
                 s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
                 s -> s
               where
-                subscriber = atomically $ do
-                  msg <- peekMsg q
-                  let encMsg = encryptMsg qr msg
-                  writeTBQueue sndQ (CorrId "", rId, MSG encMsg)
-                  s <- readTVar sub
-                  void $ setDelivered s msg
-                  writeTVar sub s {subThread = NoSub}
+                subscriber = do
+                  msg <- atomically $ peekMsg q
+                  time "subscriber" . atomically $ do
+                    let encMsg = encryptMsg qr msg
+                    writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
+                    s <- readTVar sub
+                    void $ setDelivered s msg
+                    writeTVar sub $! s {subThread = NoSub}
+
+        time :: T.Text -> m a -> m a
+        time name = timed name queueId
 
         encryptMsg :: QueueRec -> Message -> RcvMessage
-        encryptMsg qr Message {msgId, msgTs, msgFlags, msgBody}
-          | thVersion == 1 || thVersion == 2 = encrypt msgBody
-          | otherwise = encrypt $ encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody}
+        encryptMsg qr msg = case msg of
+          Message {msgFlags, msgBody}
+            | thVersion == 1 || thVersion == 2 -> encrypt msgFlags msgBody
+            | otherwise -> encrypt msgFlags $ encodeRcvMsgBody RcvMsgBody {msgTs = msgTs', msgFlags, msgBody}
+          MessageQuota {} ->
+            encrypt noMsgFlags $ encodeRcvMsgBody (RcvMsgQuota msgTs')
           where
-            encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
-            encrypt body =
-              let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId) body
-               in RcvMessage msgId msgTs msgFlags encBody
+            encrypt :: KnownNat i => MsgFlags -> C.MaxLenBS i -> RcvMessage
+            encrypt msgFlags body =
+              let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body
+               in RcvMessage msgId' msgTs' msgFlags encBody
+            msgId' = msgId (msg :: Message)
+            msgTs' = msgTs (msg :: Message)
 
         setDelivered :: Sub -> Message -> STM Bool
-        setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
+        setDelivered s msg = tryPutTMVar (delivered s) $ msgId (msg :: Message)
 
-        getStoreMsgQueue :: RecipientId -> m MsgQueue
-        getStoreMsgQueue rId = do
+        getStoreMsgQueue :: T.Text -> RecipientId -> m MsgQueue
+        getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
           ms <- asks msgStore
           quota <- asks $ msgQueueQuota . config
           atomically $ getMsgQueue ms rId quota
@@ -636,7 +680,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
           withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
           stats <- asks serverStats
-          atomically $ modifyTVar (qDeleted stats) (+ 1)
+          atomically $ modifyTVar' (qDeleted stats) (+ 1)
+          atomically $ modifyTVar' (qCount stats) (subtract 1)
           atomically $
             deleteQueue st queueId >>= \case
               Left e -> pure $ err e
@@ -656,6 +701,18 @@ withLog action = do
   env <- ask
   liftIO . mapM_ action $ storeLog (env :: Env)
 
+timed :: MonadUnliftIO m => T.Text -> RecipientId -> m a -> m a
+timed name qId a = do
+  t <- liftIO getSystemTime
+  r <- a
+  t' <- liftIO getSystemTime
+  let int = diff t t'
+  when (int > sec) . logDebug $ T.unwords [name, tshow $ encode qId, tshow int]
+  pure r
+  where
+    diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t)
+    sec = 1000_000000
+
 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg
@@ -703,8 +760,11 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
             addToMsgQueue rId msg = do
               full <- atomically $ do
                 q <- getMsgQueue ms rId quota
-                ifM (isFull q) (pure True) (writeMsg q msg $> False)
-              when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
+                isNothing <$> writeMsg q msg
+              case msg of
+                Message {} ->
+                  when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
+                MessageQuota {} -> pure ()
             updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
               let nonce = C.cbNonce msgId
               msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
@@ -714,7 +774,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
 
 saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
 saveServerStats =
-  asks (serverStatsFile . config)
+  asks (serverStatsBackupFile . config)
     >>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
@@ -723,14 +783,18 @@ saveServerStats =
       logInfo "server stats saved"
 
 restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
-restoreServerStats = asks (serverStatsFile . config) >>= mapM_ restoreStats
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
       logInfo $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          atomically $ setServerStatsData s d
+          _qCount <- fmap (length . M.keys) . readTVarIO . queues =<< asks queueStore
+          _msgCount <- foldM (\n q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore
+          atomically $ setServerStats s d {_qCount, _msgCount}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
-        Left e -> logInfo $ "error restoring server stats: " <> T.pack e
+        Left e -> do
+          logInfo $ "error restoring server stats: " <> T.pack e
+          liftIO exitFailure

src/Simplex/Messaging/Server/CLI.hs

@@ -13,213 +13,134 @@ import Control.Monad
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight)
-import Data.Ini (Ini, lookupValue, readIniFile)
-import Data.Maybe (fromMaybe)
+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
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (loadFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
+import Simplex.Messaging.Util (eitherToMaybe, whenM)
+import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
-import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
+import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile)
 import System.Process (readCreateProcess, shell)
-import Text.Read (readMaybe)
-
-data ServerCLIConfig cfg = ServerCLIConfig
-  { cfgDir :: FilePath,
-    logDir :: FilePath,
-    iniFile :: FilePath,
-    storeLogFile :: FilePath,
-    caKeyFile :: FilePath,
-    caCrtFile :: FilePath,
-    serverKeyFile :: FilePath,
-    serverCrtFile :: FilePath,
-    fingerprintFile :: FilePath,
-    defaultServerPort :: ServiceName,
-    executableName :: String,
-    serverVersion :: String,
-    mkIniFile :: Bool -> ServiceName -> String,
-    mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
-  }
-
-protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
-protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
-  getCliCommand cliCfg >>= \case
-    Init opts ->
-      doesFileExist iniFile >>= \case
-        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
-        _ -> initializeServer cliCfg opts
-    Start ->
-      doesFileExist iniFile >>= \case
-        True -> readIniFile iniFile >>= either exitError (runServer cliCfg server)
-        _ -> 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!"
-      cleanup cliCfg
-      putStrLn "Deleted configuration and log files"
 
 exitError :: String -> IO ()
 exitError msg = putStrLn msg >> exitFailure
 
 confirmOrExit :: String -> IO ()
-confirmOrExit s = do
-  putStrLn s
-  putStr "Continue (Y/n): "
-  hFlush stdout
-  ok <- getLine
-  when (ok /= "Y") exitFailure
-
-data CliCommand
-  = Init InitOptions
-  | Start
-  | Delete
-
-data InitOptions = InitOptions
-  { enableStoreLog :: Bool,
-    signAlgorithm :: SignAlgorithm,
-    ip :: HostName,
-    fqdn :: Maybe HostName
-  }
-  deriving (Show)
+confirmOrExit s =
+  withPrompt (s <> "\nContinue (Y/n): ") $ do
+    ok <- getLine
+    when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
 
 data SignAlgorithm = ED448 | ED25519
   deriving (Read, Show)
 
-getCliCommand :: ServerCLIConfig cfg -> IO CliCommand
-getCliCommand cliCfg =
+data X509Config = X509Config
+  { commonName :: HostName,
+    signAlgorithm :: SignAlgorithm,
+    caKeyFile :: FilePath,
+    caCrtFile :: FilePath,
+    serverKeyFile :: FilePath,
+    serverCrtFile :: FilePath,
+    fingerprintFile :: FilePath,
+    opensslCaConfFile :: FilePath,
+    opensslServerConfFile :: FilePath,
+    serverCsrFile :: FilePath
+  }
+
+defaultX509Config :: X509Config
+defaultX509Config =
+  X509Config
+    { commonName = "127.0.0.1",
+      signAlgorithm = ED448,
+      caKeyFile = "ca.key",
+      caCrtFile = "ca.crt",
+      serverKeyFile = "server.key",
+      serverCrtFile = "server.crt",
+      fingerprintFile = "fingerprint",
+      opensslCaConfFile = "openssl_ca.conf",
+      opensslServerConfFile = "openssl_server.conf",
+      serverCsrFile = "server.csr"
+    }
+
+getCliCommand' :: Parser cmd -> String -> IO cmd
+getCliCommand' cmdP version =
   customExecParser
     (prefs showHelpOnEmpty)
     ( info
-        (helper <*> versionOption <*> cliCommandP cliCfg)
+        (helper <*> versionOption <*> cmdP)
         (header version <> fullDesc)
     )
   where
     versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
-    version = serverVersion cliCfg
 
-cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand
-cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
-  hsubparser
-    ( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " 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"))
-    )
+createServerX509 :: FilePath -> X509Config -> IO ByteString
+createServerX509 cfgPath x509cfg = do
+  createOpensslCaConf
+  createOpensslServerConf
+  let alg = show $ signAlgorithm (x509cfg :: X509Config)
+  -- CA certificate (identity/offline)
+  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile
+  run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile
+  -- server certificate (online)
+  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c serverKeyFile
+  run $ "openssl req -new -config " <> c opensslServerConfFile <> " -reqexts v3 -key " <> c serverKeyFile <> " -out " <> c serverCsrFile
+  run $ "openssl x509 -req -days 999999 -extfile " <> c opensslServerConfFile <> " -extensions v3 -in " <> c serverCsrFile <> " -CA " <> c caCrtFile <> " -CAkey " <> c caKeyFile <> " -CAcreateserial -out " <> c serverCrtFile
+  saveFingerprint
   where
-    initP :: Parser CliCommand
-    initP =
-      Init
-        <$> ( 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"
-                  )
-            )
-
-initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
-initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
-  cleanup cliCfg
-  createDirectoryIfMissing True cfgDir
-  createDirectoryIfMissing True logDir
-  createX509
-  fp <- saveFingerprint
-  writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort
-  putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
-  printServiceInfo cliCfg fp
-  warnCAPrivateKeyFile
-  where
-    ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg
-    createX509 = do
-      createOpensslCaConf
-      createOpensslServerConf
-      -- CA certificate (identity/offline)
-      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
-      run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
-      -- server certificate (online)
-      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
-      run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
-      run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
-      where
-        run cmd = void $ readCreateProcess (shell cmd) ""
-        opensslCaConfFile = combine cfgDir "openssl_ca.conf"
-        opensslServerConfFile = combine cfgDir "openssl_server.conf"
-        serverCsrFile = combine cfgDir "server.csr"
-        createOpensslCaConf =
-          writeFile
-            opensslCaConfFile
-            "[req]\n\
-            \distinguished_name = req_distinguished_name\n\
-            \prompt = no\n\n\
-            \[req_distinguished_name]\n\
-            \CN = SMP server CA\n\
-            \O = SimpleX\n\n\
-            \[v3]\n\
-            \subjectKeyIdentifier = hash\n\
-            \authorityKeyIdentifier = keyid:always\n\
-            \basicConstraints = critical,CA:true\n"
-        -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
-        -- IP and FQDN can't both be used as server address interchangeably even if IP is added
-        -- as Subject Alternative Name, unless the following validation hook is disabled:
-        -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
-        createOpensslServerConf =
-          writeFile
-            opensslServerConfFile
-            ( "[req]\n\
-              \distinguished_name = req_distinguished_name\n\
-              \prompt = no\n\n\
-              \[req_distinguished_name]\n"
-                <> ("CN = " <> cn <> "\n\n")
-                <> "[v3]\n\
-                   \basicConstraints = CA:FALSE\n\
-                   \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
-                   \extendedKeyUsage = serverAuth\n"
-            )
-          where
-            cn = fromMaybe ip fqdn
+    run cmd = void $ readCreateProcess (shell cmd) ""
+    c = combine cfgPath . ($ x509cfg)
+    createOpensslCaConf =
+      writeFile
+        (c opensslCaConfFile)
+        "[req]\n\
+        \distinguished_name = req_distinguished_name\n\
+        \prompt = no\n\n\
+        \[req_distinguished_name]\n\
+        \CN = SMP server CA\n\
+        \O = SimpleX\n\n\
+        \[v3]\n\
+        \subjectKeyIdentifier = hash\n\
+        \authorityKeyIdentifier = keyid:always\n\
+        \basicConstraints = critical,CA:true\n"
+    createOpensslServerConf =
+      writeFile
+        (c opensslServerConfFile)
+        ( "[req]\n\
+          \distinguished_name = req_distinguished_name\n\
+          \prompt = no\n\n\
+          \[req_distinguished_name]\n"
+            <> ("CN = " <> commonName x509cfg <> "\n\n")
+            <> "[v3]\n\
+               \basicConstraints = CA:FALSE\n\
+               \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
+               \extendedKeyUsage = serverAuth\n"
+        )
 
     saveFingerprint = do
-      Fingerprint fp <- loadFingerprint caCrtFile
-      withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
+      Fingerprint fp <- loadFingerprint $ c caCrtFile
+      withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
       pure fp
 
-    warnCAPrivateKeyFile =
-      putStrLn $
-        "----------\n\
-        \You should store CA private key securely and delete it from the server.\n\
-        \If server TLS credential is compromised this key can be used to sign a new one, \
-        \keeping the same server identity and established connections.\n\
-        \CA private key location:\n"
-          <> caKeyFile
-          <> "\n----------"
+warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
+warnCAPrivateKeyFile cfgPath X509Config {caKeyFile} =
+  putStrLn $
+    "----------\n\
+    \You should store CA private key securely and delete it from the server.\n\
+    \If server TLS credential is compromised this key can be used to sign a new one, \
+    \keeping the same server identity and established connections.\n\
+    \CA private key location:\n"
+      <> combine cfgPath caKeyFile
+      <> "\n----------"
 
 data IniOptions = IniOptions
   { enableStoreLog :: Bool,
@@ -235,50 +156,79 @@ mkIniOptions ini =
       enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
     }
 
-strictIni :: String -> String -> Ini -> T.Text
+strictIni :: Text -> Text -> Ini -> Text
 strictIni section key ini =
-  fromRight (error ("no key " <> key <> " in section " <> section)) $
-    lookupValue (T.pack section) (T.pack key) ini
+  fromRight (error . T.unpack $ "no key " <> key <> " in section " <> section) $
+    lookupValue section key ini
 
-readStrictIni :: Read a => String -> String -> Ini -> a
+readStrictIni :: Read a => Text -> Text -> Ini -> a
 readStrictIni section key = read . T.unpack . strictIni section key
 
-runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()
-runServer cliCfg server ini = do
-  hSetBuffering stdout LineBuffering
-  hSetBuffering stderr LineBuffering
-  fp <- checkSavedFingerprint
-  printServiceInfo cliCfg fp
-  let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini
-      transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
-      logFile = if enableStoreLog then Just storeLogFile else Nothing
-      cfg = mkServerConfig logFile transports ini
-  printServerConfig logFile transports
-  server cfg
+iniOnOff :: Text -> Text -> Ini -> Maybe Bool
+iniOnOff section name ini = case lookupValue section name ini of
+  Right "on" -> Just True
+  Right "off" -> Just False
+  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
+
+onOffPrompt :: String -> Bool -> IO Bool
+onOffPrompt prompt def =
+  withPrompt (prompt <> if def then " (Yn): " else " (yN): ") $
+    getLine >>= \case
+      "" -> pure def
+      "y" -> pure True
+      "Y" -> pure True
+      "n" -> pure False
+      "N" -> pure False
+      _ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def
+
+onOff :: Bool -> String
+onOff True = "on"
+onOff _ = "off"
+
+settingIsOn :: Text -> Text -> Ini -> Maybe ()
+settingIsOn section name ini
+  | iniOnOff section name ini == Just True = Just ()
+  | otherwise = Nothing
+
+checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
+checkSavedFingerprint cfgPath x509cfg = do
+  savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine
+  Fingerprint fp <- loadFingerprint (c caCrtFile)
+  when (B.pack savedFingerprint /= strEncode fp) $
+    exitError "Stored fingerprint is invalid."
+  pure fp
   where
-    ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg
-    checkSavedFingerprint = do
-      savedFingerprint <- withFile fingerprintFile ReadMode hGetLine
-      Fingerprint fp <- loadFingerprint caCrtFile
-      when (B.pack savedFingerprint /= strEncode fp) $
-        exitError "Stored fingerprint is invalid."
-      pure fp
+    c = combine cfgPath . ($ x509cfg)
 
-    printServerConfig logFile transports = do
-      putStrLn $ case logFile of
-        Just f -> "Store log: " <> f
-        _ -> "Store log disabled."
-      forM_ transports $ \(p, ATransport t) ->
-        putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
+iniTransports :: Ini -> [(String, ATransport)]
+iniTransports ini =
+  let port = T.unpack $ strictIni "TRANSPORT" "port" ini
+      enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
+   in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
 
-cleanup :: ServerCLIConfig cfg -> IO ()
-cleanup ServerCLIConfig {cfgDir, logDir} = do
-  deleteDirIfExists cfgDir
-  deleteDirIfExists logDir
-  where
-    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
+printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
+printServerConfig transports logFile = do
+  putStrLn $ case logFile of
+    Just f -> "Store log: " <> f
+    _ -> "Store log disabled."
+  forM_ transports $ \(p, ATransport t) ->
+    putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
 
-printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
-printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
+deleteDirIfExists :: FilePath -> IO ()
+deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
+
+printServiceInfo :: ProtocolTypeI p => String -> ProtoServerWithAuth p -> IO ()
+printServiceInfo serverVersion srv@(ProtoServerWithAuth ProtocolServer {keyHash} _) = do
   putStrLn serverVersion
-  B.putStrLn $ "Fingerprint: " <> strEncode fpStr
+  B.putStrLn $ "Fingerprint: " <> strEncode keyHash
+  B.putStrLn $ "Server address: " <> strEncode srv
+
+clearDirIfExists :: FilePath -> IO ()
+clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)

src/Simplex/Messaging/Server/Env/STM.hs

@@ -9,6 +9,7 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Time.Clock (getCurrentTime)
@@ -38,13 +39,15 @@ data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport)],
     tbqSize :: Natural,
     serverTbqSize :: Natural,
-    msgQueueQuota :: Natural,
+    msgQueueQuota :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
     storeMsgsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
+    -- | simple password that the clients need to pass in handshake to be able to create new queues
+    newQueueBasicAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
     -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -55,14 +58,17 @@ data ServerConfig = ServerConfig
     -- | time of the day when the stats are logged first, to log at consistent times,
     -- irrespective of when the server is started (seconds from 00:00 UTC)
     logStatsStartTime :: Int,
+    -- | file to log stats
+    serverStatsLogFile :: FilePath,
     -- | file to save and restore stats
-    serverStatsFile :: Maybe FilePath,
+    serverStatsBackupFile :: Maybe FilePath,
     -- | CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
     -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange
+    smpServerVRange :: VersionRange,
+    logTLSErrors :: Bool
   }
 
 defaultMessageExpiration :: ExpirationConfig
@@ -101,8 +107,8 @@ data Server = Server
 data Client = Client
   { subscriptions :: TMap RecipientId (TVar Sub),
     ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (Transmission Cmd),
-    sndQ :: TBQueue (Transmission BrokerMsg),
+    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
+    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     thVersion :: Version,
     sessionId :: ByteString,
     connected :: TVar Bool,
@@ -158,8 +164,8 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
       (qs, s') <- liftIO $ readWriteStoreLog s
       atomically $ do
         writeTVar queues =<< mapM newTVar qs
-        writeTVar senders $ M.foldr' addSender M.empty qs
-        writeTVar notifiers $ M.foldr' addNotifier M.empty qs
+        writeTVar senders $! M.foldr' addSender M.empty qs
+        writeTVar notifiers $! M.foldr' addNotifier M.empty qs
       pure s'
     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
     addSender q = M.insert (senderId q) (recipientId q)

src/Simplex/Messaging/Server/Main.hs

@@ -0,0 +1,283 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Simplex.Messaging.Server.Main where
+
+import Control.Monad (void)
+import Crypto.Random (getRandomBytes)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Ini (lookupValue, readIniFile)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Network.Socket (HostName)
+import Options.Applicative
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
+import Simplex.Messaging.Server (runSMPServer)
+import Simplex.Messaging.Server.CLI
+import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
+import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Util (safeDecodeUtf8)
+import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.FilePath (combine)
+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
+import Text.Read (readMaybe)
+
+smpServerCLI :: FilePath -> FilePath -> IO ()
+smpServerCLI cfgPath logPath =
+  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 "smp-server.ini"
+    serverVersion = "SMP server v" <> simplexMQVersion
+    defaultServerPort = "5223"
+    executableName = "smp-server"
+    storeLogFilePath = combine logPath "smp-server-store.log"
+    initializeServer opts
+      | scripted opts = initialize opts
+      | otherwise = do
+        putStrLn "Use `smp-server init -h` for available options."
+        void $ withPrompt "SMP server will be initialized (press Enter)" getLine
+        enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
+        logStats <- onOffPrompt "Enable logging daily statistics" False
+        putStrLn "Require a password to create new messaging queues?"
+        password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
+        let host = fromMaybe (ip opts) (fqdn opts)
+        host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
+        initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
+      where
+        serverPassword =
+          getLine >>= \case
+            "" -> pure $ Just SPRandom
+            "r" -> pure $ Just SPRandom
+            "n" -> pure Nothing
+            s ->
+              case strDecode $ encodeUtf8 $ T.pack s of
+                Right auth -> pure . Just $ ServerPassword auth
+                _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
+        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password} = do
+          clearDirIfExists cfgPath
+          clearDirIfExists logPath
+          createDirectoryIfMissing True cfgPath
+          createDirectoryIfMissing True logPath
+          let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
+          fp <- createServerX509 cfgPath x509cfg
+          basicAuth <- mapM createServerPassword password
+          let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
+              srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
+          writeFile iniFile $ iniFileContent host basicAuth
+          putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
+          warnCAPrivateKeyFile cfgPath x509cfg
+          printServiceInfo serverVersion srv
+          where
+            createServerPassword = \case
+              ServerPassword s -> pure s
+              SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString)
+            iniFileContent host basicAuth =
+              "[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")
+                <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
+                   \# they are preserved in the .bak file until the next restart.\n"
+                <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
+                <> "# Log daily server statistics to CSV file\n"
+                <> ("log_stats: " <> onOff logStats <> "\n\n")
+                <> "[AUTH]\n\
+                   \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
+                   \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
+                   \new_queues: on\n\n\
+                   \# Use create_password option to enable basic auth to create new messaging queues.\n\
+                   \# The password should be used as part of server address in client configuration:\n\
+                   \# smp://fingerprint:password@host1,host2\n\
+                   \# The password will not be shared with the connecting contacts, you must share it only\n\
+                   \# with the users who you want to allow creating messaging queues on your server.\n"
+                <> ( case basicAuth of
+                       Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
+                       _ -> "# create_password: password to create new queues (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\
+                   \websockets: off\n\n\
+                   \[INACTIVE_CLIENTS]\n\
+                   \# TTL and interval to check inactive clients\n\
+                   \disconnect: off\n"
+                <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
+                <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
+    runServer ini = do
+      hSetBuffering stdout LineBuffering
+      hSetBuffering stderr LineBuffering
+      fp <- checkSavedFingerprint cfgPath defaultX509Config
+      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
+          port = T.unpack $ strictIni "TRANSPORT" "port" ini
+          cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, inactiveClientExpiration} = serverConfig
+          srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
+      printServiceInfo serverVersion srv
+      printServerConfig transports storeLogFile
+      putStrLn $ case inactiveClientExpiration of
+        Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
+        _ -> "not expiring inactive clients"
+      putStrLn $
+        "creating new queues "
+          <> if allowNewQueues cfg
+            then maybe "allowed" (const "requires password") newQueueBasicAuth
+            else "NOT allowed"
+      runSMPServer cfg
+      where
+        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+        logStats = settingIsOn "STORE_LOG" "log_stats" ini
+        c = combine cfgPath . ($ defaultX509Config)
+        serverConfig =
+          ServerConfig
+            { transports = iniTransports ini,
+              tbqSize = 32,
+              serverTbqSize = 128,
+              msgQueueQuota = 128,
+              queueIdBytes = 24,
+              msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
+              caCertificateFile = c caCrtFile,
+              privateKeyFile = c serverKeyFile,
+              certificateFile = c serverCrtFile,
+              storeLogFile = enableStoreLog $> storeLogFilePath,
+              storeMsgsFile =
+                let messagesPath = combine logPath "smp-server-messages.log"
+                 in case iniOnOff "STORE_LOG" "restore_messages" ini of
+                      Just True -> Just messagesPath
+                      Just False -> Nothing
+                      -- if the setting is not set, it is enabled when store log is enabled
+                      _ -> enableStoreLog $> messagesPath,
+              -- allow creating new queues by default
+              allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
+              newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
+              messageExpiration = Just defaultMessageExpiration,
+              inactiveClientExpiration =
+                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
+                  $> ExpirationConfig
+                    { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
+                      checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
+                    },
+              logStatsInterval = logStats $> 86400, -- seconds
+              logStatsStartTime = 0, -- seconds from 00:00 UTC
+              serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
+              serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
+              smpServerVRange = supportedSMPServerVRange,
+              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+            }
+
+data CliCommand
+  = Init InitOptions
+  | Start
+  | Delete
+
+data InitOptions = InitOptions
+  { enableStoreLog :: Bool,
+    logStats :: Bool,
+    signAlgorithm :: SignAlgorithm,
+    ip :: HostName,
+    fqdn :: Maybe HostName,
+    password :: Maybe ServerPassword,
+    scripted :: Bool
+  }
+  deriving (Show)
+
+data ServerPassword = ServerPassword BasicAuth | SPRandom
+  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 = do
+      enableStoreLog <-
+        switch
+          ( long "store-log"
+              <> short 'l'
+              <> help "Enable store log for persistence"
+          )
+      logStats <-
+        switch
+          ( long "daily-stats"
+              <> short 's'
+              <> help "Enable logging daily server statistics"
+          )
+      signAlgorithm <-
+        option
+          (maybeReader readMaybe)
+          ( long "sign-algorithm"
+              <> short 'a'
+              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
+              <> value ED448
+              <> showDefault
+              <> metavar "ALG"
+          )
+      ip <-
+        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"
+          )
+      fqdn <-
+        (optional . strOption)
+          ( long "fqdn"
+              <> short 'n'
+              <> help "Server FQDN used as Common Name for TLS online certificate"
+              <> showDefault
+              <> metavar "FQDN"
+          )
+      password <-
+        flag' Nothing (long "no-password" <> help "Allow creating new queues without password")
+          <|> Just
+            <$> option
+              parseBasicAuth
+              ( long "password"
+                  <> metavar "PASSWORD"
+                  <> help "Set password to create new messaging queues"
+                  <> value SPRandom
+              )
+      scripted <-
+        switch
+          ( long "yes"
+              <> short 'y'
+              <> help "Non-interactive initialization using command-line options"
+          )
+      pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted}
+    parseBasicAuth :: ReadM ServerPassword
+    parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack

src/Simplex/Messaging/Server/MsgStore.hs

@@ -1,14 +1,11 @@
-{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Messaging.Server.MsgStore where
 
 import Control.Applicative ((<|>))
-import Data.Int (Int64)
-import Numeric.Natural
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (Message (..), MsgId, RcvMessage (..), RecipientId)
+import Simplex.Messaging.Protocol (Message (..), RcvMessage (..), RecipientId)
 
 data MsgLogRecord = MLRv3 RecipientId Message | MLRv1 RecipientId RcvMessage
 
@@ -17,17 +14,3 @@ instance StrEncoding MsgLogRecord where
     MLRv3 rId msg -> strEncode (Str "v3", rId, msg)
     MLRv1 rId msg -> strEncode (rId, msg)
   strP = "v3 " *> (MLRv3 <$> strP_ <*> strP) <|> MLRv1 <$> strP_ <*> strP
-
-class MonadMsgStore s q m | s -> q where
-  getMsgQueue :: s -> RecipientId -> Natural -> m q
-  delMsgQueue :: s -> RecipientId -> m ()
-  flushMsgQueue :: s -> RecipientId -> m [Message]
-
-class MonadMsgQueue q m where
-  isFull :: q -> m Bool
-  writeMsg :: q -> Message -> m () -- non blocking
-  tryPeekMsg :: q -> m (Maybe Message) -- non blocking
-  peekMsg :: q -> m Message -- blocking
-  tryDelMsg :: q -> MsgId -> m Bool -- non blocking
-  tryDelPeekMsg :: q -> MsgId -> m (Bool, Maybe Message) -- atomic delete (== read) last and peek next message, if available
-  deleteExpiredMsgs :: q -> Int64 -> m ()

src/Simplex/Messaging/Server/MsgStore/STM.hs

@@ -1,83 +1,120 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TupleSections #-}
 
-module Simplex.Messaging.Server.MsgStore.STM where
+module Simplex.Messaging.Server.MsgStore.STM
+  ( STMMsgStore,
+    MsgQueue (..),
+    newMsgStore,
+    getMsgQueue,
+    delMsgQueue,
+    flushMsgQueue,
+    writeMsg,
+    tryPeekMsg,
+    peekMsg,
+    tryDelMsg,
+    tryDelPeekMsg,
+    deleteExpiredMsgs,
+  )
+where
 
-import Control.Concurrent.STM.TBQueue (flushTBQueue)
+import Control.Concurrent.STM.TQueue (flushTQueue)
 import Control.Monad (when)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime (systemSeconds))
-import Numeric.Natural
 import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
-import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import UnliftIO.STM
 
-newtype MsgQueue = MsgQueue {msgQueue :: TBQueue Message}
+data MsgQueue = MsgQueue
+  { msgQueue :: TQueue Message,
+    quota :: Int,
+    canWrite :: TVar Bool,
+    size :: TVar Int
+  }
 
 type STMMsgStore = TMap RecipientId MsgQueue
 
 newMsgStore :: STM STMMsgStore
 newMsgStore = TM.empty
 
-instance MonadMsgStore STMMsgStore MsgQueue STM where
-  getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
-  getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
-    where
-      newQ = do
-        q <- MsgQueue <$> newTBQueue quota
-        TM.insert rId q st
-        return q
+getMsgQueue :: STMMsgStore -> RecipientId -> Int -> STM MsgQueue
+getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
+  where
+    newQ = do
+      msgQueue <- newTQueue
+      canWrite <- newTVar True
+      size <- newTVar 0
+      let q = MsgQueue {msgQueue, quota, canWrite, size}
+      TM.insert rId q st
+      pure q
 
-  delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
-  delMsgQueue st rId = TM.delete rId st
+delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
+delMsgQueue st rId = TM.delete rId st
 
-  flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
-  flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
+flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
 
-instance MonadMsgQueue MsgQueue STM where
-  isFull :: MsgQueue -> STM Bool
-  isFull = isFullTBQueue . msgQueue
+writeMsg :: MsgQueue -> Message -> STM (Maybe Message)
+writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do
+  canWrt <- readTVar canWrite
+  empty <- isEmptyTQueue q
+  if canWrt || empty
+    then do
+      canWrt' <- (quota >) <$> readTVar size
+      writeTVar canWrite $! canWrt'
+      modifyTVar' size (+ 1)
+      if canWrt'
+        then writeTQueue q msg $> Just msg
+        else writeTQueue q msgQuota $> Nothing
+    else pure Nothing
+  where
+    msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
 
-  writeMsg :: MsgQueue -> Message -> STM ()
-  writeMsg = writeTBQueue . msgQueue
+tryPeekMsg :: MsgQueue -> STM (Maybe Message)
+tryPeekMsg = tryPeekTQueue . msgQueue
+{-# INLINE tryPeekMsg #-}
 
-  tryPeekMsg :: MsgQueue -> STM (Maybe Message)
-  tryPeekMsg = tryPeekTBQueue . msgQueue
+peekMsg :: MsgQueue -> STM Message
+peekMsg = peekTQueue . msgQueue
+{-# INLINE peekMsg #-}
 
-  peekMsg :: MsgQueue -> STM Message
-  peekMsg = peekTBQueue . msgQueue
+tryDelMsg :: MsgQueue -> MsgId -> STM (Maybe Message)
+tryDelMsg mq msgId' =
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_
+      | otherwise -> pure Nothing
+    _ -> pure Nothing
 
-  tryDelMsg :: MsgQueue -> MsgId -> STM Bool
-  tryDelMsg (MsgQueue q) msgId' =
-    tryPeekTBQueue q >>= \case
-      Just Message {msgId}
-        | msgId == msgId' || B.null msgId' -> tryReadTBQueue q $> True
-        | otherwise -> pure False
-      _ -> pure False
+-- atomic delete (== read) last and peek next message if available
+tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message)
+tryDelPeekMsg mq msgId' =
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
+      | otherwise -> pure (Nothing, msg_)
+    _ -> pure (Nothing, Nothing)
 
-  -- atomic delete (== read) last and peek next message if available
-  tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Bool, Maybe Message)
-  tryDelPeekMsg (MsgQueue q) msgId' =
-    tryPeekTBQueue q >>= \case
-      msg_@(Just Message {msgId})
-        | msgId == msgId' || B.null msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
-        | otherwise -> pure (False, msg_)
-      _ -> pure (False, Nothing)
-
-  deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
-  deleteExpiredMsgs (MsgQueue q) old = loop
-    where
-      loop = tryPeekTBQueue q >>= mapM_ delOldMsg
-      delOldMsg Message {msgTs} =
+deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
+deleteExpiredMsgs mq old = loop
+  where
+    loop = tryPeekMsg mq >>= mapM_ delOldMsg
+    delOldMsg = \case
+      Message {msgTs} ->
         when (systemSeconds msgTs < old) $
-          tryReadTBQueue q >> loop
+          tryDeleteMsg mq >> loop
+      _ -> pure ()
+
+tryDeleteMsg :: MsgQueue -> STM ()
+tryDeleteMsg MsgQueue {msgQueue = q, size} =
+  tryReadTQueue q >>= \case
+    Just _ -> modifyTVar' size (subtract 1)
+    _ -> pure ()

src/Simplex/Messaging/Server/QueueStore.hs

@@ -9,20 +9,20 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 
 data QueueRec = QueueRec
-  { recipientId :: RecipientId,
-    recipientKey :: RcvPublicVerifyKey,
-    rcvDhSecret :: RcvDhSecret,
-    senderId :: SenderId,
-    senderKey :: Maybe SndPublicVerifyKey,
-    notifier :: Maybe NtfCreds,
-    status :: QueueStatus
+  { recipientId :: !RecipientId,
+    recipientKey :: !RcvPublicVerifyKey,
+    rcvDhSecret :: !RcvDhSecret,
+    senderId :: !SenderId,
+    senderKey :: !(Maybe SndPublicVerifyKey),
+    notifier :: !(Maybe NtfCreds),
+    status :: !ServerQueueStatus
   }
   deriving (Eq, Show)
 
 data NtfCreds = NtfCreds
-  { notifierId :: NotifierId,
-    notifierKey :: NtfPublicVerifyKey,
-    rcvNtfDhSecret :: RcvNtfDhSecret
+  { notifierId :: !NotifierId,
+    notifierKey :: !NtfPublicVerifyKey,
+    rcvNtfDhSecret :: !RcvNtfDhSecret
   }
   deriving (Eq, Show)
 
@@ -32,13 +32,4 @@ instance StrEncoding NtfCreds where
     (notifierId, notifierKey, rcvNtfDhSecret) <- strP
     pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
 
-data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
-
-class MonadQueueStore s m where
-  addQueue :: s -> QueueRec -> m (Either ErrorType ())
-  getQueue :: s -> SParty p -> QueueId -> m (Either ErrorType QueueRec)
-  secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType QueueRec)
-  addQueueNotifier :: s -> RecipientId -> NtfCreds -> m (Either ErrorType QueueRec)
-  deleteQueueNotifier :: s -> RecipientId -> m (Either ErrorType ())
-  suspendQueue :: s -> RecipientId -> m (Either ErrorType ())
-  deleteQueue :: s -> RecipientId -> m (Either ErrorType ())
+data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)

src/Simplex/Messaging/Server/QueueStore/STM.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -10,7 +9,18 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Simplex.Messaging.Server.QueueStore.STM where
+module Simplex.Messaging.Server.QueueStore.STM
+  ( QueueStore (..),
+    newQueueStore,
+    addQueue,
+    getQueue,
+    secureQueue,
+    addQueueNotifier,
+    deleteQueueNotifier,
+    suspendQueue,
+    deleteQueue,
+  )
+where
 
 import Control.Monad
 import Data.Functor (($>))
@@ -34,64 +44,65 @@ newQueueStore = do
   notifiers <- TM.empty
   pure QueueStore {queues, senders, notifiers}
 
-instance MonadQueueStore QueueStore STM where
-  addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
-  addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
-    ifM hasId (pure $ Left DUPLICATE_) $ do
-      qVar <- newTVar q
-      TM.insert rId qVar queues
-      TM.insert sId rId senders
-      pure $ Right ()
-    where
-      hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
+addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
+addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
+  ifM hasId (pure $ Left DUPLICATE_) $ do
+    qVar <- newTVar q
+    TM.insert rId qVar queues
+    TM.insert sId rId senders
+    pure $ Right ()
+  where
+    hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
 
-  getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
-  getQueue QueueStore {queues, senders, notifiers} party qId =
-    toResult <$> (mapM readTVar =<< getVar)
-    where
-      getVar = case party of
-        SRecipient -> TM.lookup qId queues
-        SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
-        SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
+getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
+getQueue QueueStore {queues, senders, notifiers} party qId =
+  toResult <$> (mapM readTVar =<< getVar)
+  where
+    getVar = case party of
+      SRecipient -> TM.lookup qId queues
+      SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
+      SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
 
-  secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
-  secureQueue QueueStore {queues} rId sKey =
-    withQueue rId queues $ \qVar ->
-      readTVar qVar >>= \q -> case senderKey q of
-        Just _ -> pure Nothing
-        _ -> writeTVar qVar q {senderKey = Just sKey} $> Just q
+secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
+secureQueue QueueStore {queues} rId sKey =
+  withQueue rId queues $ \qVar ->
+    readTVar qVar >>= \q -> case senderKey q of
+      Just k -> pure $ if sKey == k then Just q else Nothing
+      _ ->
+        let q' = q {senderKey = Just sKey}
+         in writeTVar qVar q' $> Just q'
 
-  addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
-  addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
-    ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
-      withQueue rId queues $ \qVar -> do
-        q <- readTVar qVar
-        forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
-        writeTVar qVar q {notifier = Just ntfCreds}
-        TM.insert nId rId notifiers
-        pure $ Just q
-
-  deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  deleteQueueNotifier QueueStore {queues, notifiers} rId =
+addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
+addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
+  ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
     withQueue rId queues $ \qVar -> do
       q <- readTVar qVar
-      forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-      writeTVar qVar q {notifier = Nothing}
-      pure $ Just ()
+      forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
+      writeTVar qVar $! q {notifier = Just ntfCreds}
+      TM.insert nId rId notifiers
+      pure $ Just q
 
-  suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  suspendQueue QueueStore {queues} rId =
-    withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
+deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+deleteQueueNotifier QueueStore {queues, notifiers} rId =
+  withQueue rId queues $ \qVar -> do
+    q <- readTVar qVar
+    forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
+    writeTVar qVar $! q {notifier = Nothing}
+    pure $ Just ()
 
-  deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
-  deleteQueue QueueStore {queues, senders, notifiers} rId = do
-    TM.lookupDelete rId queues >>= \case
-      Just qVar ->
-        readTVar qVar >>= \q -> do
-          TM.delete (senderId q) senders
-          forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-          pure $ Right ()
-      _ -> pure $ Left AUTH
+suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+suspendQueue QueueStore {queues} rId =
+  withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
+
+deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+deleteQueue QueueStore {queues, senders, notifiers} rId = do
+  TM.lookupDelete rId queues >>= \case
+    Just qVar ->
+      readTVar qVar >>= \q -> do
+        TM.delete (senderId q) senders
+        forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
+        pure $ Right ()
+    _ -> pure $ Left AUTH
 
 toResult :: Maybe a -> Either ErrorType a
 toResult = maybe (Left AUTH) Right

src/Simplex/Messaging/Server/Stats.hs

@@ -1,14 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Server.Stats where
 
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Time.Clock (UTCTime)
+import Data.Time.Calendar.Month.Compat (pattern MonthDay)
+import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
+import Data.Time.Clock (UTCTime (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RecipientId)
 import UnliftIO.STM
@@ -20,9 +25,12 @@ data ServerStats = ServerStats
     qDeleted :: TVar Int,
     msgSent :: TVar Int,
     msgRecv :: TVar Int,
-    dayMsgQueues :: TVar (Set RecipientId),
-    weekMsgQueues :: TVar (Set RecipientId),
-    monthMsgQueues :: TVar (Set RecipientId)
+    activeQueues :: PeriodStats RecipientId,
+    msgSentNtf :: TVar Int,
+    msgRecvNtf :: TVar Int,
+    activeQueuesNtf :: PeriodStats RecipientId,
+    qCount :: TVar Int,
+    msgCount :: TVar Int
   }
 
 data ServerStatsData = ServerStatsData
@@ -32,10 +40,14 @@ data ServerStatsData = ServerStatsData
     _qDeleted :: Int,
     _msgSent :: Int,
     _msgRecv :: Int,
-    _dayMsgQueues :: Set RecipientId,
-    _weekMsgQueues :: Set RecipientId,
-    _monthMsgQueues :: Set RecipientId
+    _activeQueues :: PeriodStatsData RecipientId,
+    _msgSentNtf :: Int,
+    _msgRecvNtf :: Int,
+    _activeQueuesNtf :: PeriodStatsData RecipientId,
+    _qCount :: Int,
+    _msgCount :: Int
   }
+  deriving (Show)
 
 newServerStats :: UTCTime -> STM ServerStats
 newServerStats ts = do
@@ -45,10 +57,13 @@ newServerStats ts = do
   qDeleted <- newTVar 0
   msgSent <- newTVar 0
   msgRecv <- newTVar 0
-  dayMsgQueues <- newTVar S.empty
-  weekMsgQueues <- newTVar S.empty
-  monthMsgQueues <- newTVar S.empty
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues}
+  activeQueues <- newPeriodStats
+  msgSentNtf <- newTVar 0
+  msgRecvNtf <- newTVar 0
+  activeQueuesNtf <- newPeriodStats
+  qCount <- newTVar 0
+  msgCount <- newTVar 0
+  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
@@ -58,25 +73,31 @@ getServerStatsData s = do
   _qDeleted <- readTVar $ qDeleted s
   _msgSent <- readTVar $ msgSent s
   _msgRecv <- readTVar $ msgRecv s
-  _dayMsgQueues <- readTVar $ dayMsgQueues s
-  _weekMsgQueues <- readTVar $ weekMsgQueues s
-  _monthMsgQueues <- readTVar $ monthMsgQueues s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
+  _activeQueues <- getPeriodStatsData $ activeQueues s
+  _msgSentNtf <- readTVar $ msgSentNtf s
+  _msgRecvNtf <- readTVar $ msgRecvNtf s
+  _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
+  _qCount <- readTVar $ qCount s
+  _msgCount <- readTVar $ msgCount s
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
 
-setServerStatsData :: ServerStats -> ServerStatsData -> STM ()
-setServerStatsData s d = do
-  writeTVar (fromTime s) (_fromTime d)
-  writeTVar (qCreated s) (_qCreated d)
-  writeTVar (qSecured s) (_qSecured d)
-  writeTVar (qDeleted s) (_qDeleted d)
-  writeTVar (msgSent s) (_msgSent d)
-  writeTVar (msgRecv s) (_msgRecv d)
-  writeTVar (dayMsgQueues s) (_dayMsgQueues d)
-  writeTVar (weekMsgQueues s) (_weekMsgQueues d)
-  writeTVar (monthMsgQueues s) (_monthMsgQueues d)
+setServerStats :: ServerStats -> ServerStatsData -> STM ()
+setServerStats s d = do
+  writeTVar (fromTime s) $! _fromTime d
+  writeTVar (qCreated s) $! _qCreated d
+  writeTVar (qSecured s) $! _qSecured d
+  writeTVar (qDeleted s) $! _qDeleted d
+  writeTVar (msgSent s) $! _msgSent d
+  writeTVar (msgRecv s) $! _msgRecv d
+  setPeriodStats (activeQueues s) (_activeQueues d)
+  writeTVar (msgSentNtf s) $! _msgSentNtf d
+  writeTVar (msgRecvNtf s) $! _msgRecvNtf d
+  setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
+  writeTVar (qCount s) $! _qCount d
+  writeTVar (msgCount s) $! _qCount d
 
 instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues} =
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "qCreated=" <> strEncode _qCreated,
@@ -84,9 +105,12 @@ instance StrEncoding ServerStatsData where
         "qDeleted=" <> strEncode _qDeleted,
         "msgSent=" <> strEncode _msgSent,
         "msgRecv=" <> strEncode _msgRecv,
-        "dayMsgQueues=" <> strEncode _dayMsgQueues,
-        "weekMsgQueues=" <> strEncode _weekMsgQueues,
-        "monthMsgQueues=" <> strEncode _monthMsgQueues
+        "msgSentNtf=" <> strEncode _msgSentNtf,
+        "msgRecvNtf=" <> strEncode _msgRecvNtf,
+        "activeQueues:",
+        strEncode _activeQueues,
+        "activeQueuesNtf:",
+        strEncode _activeQueuesNtf
       ]
   strP = do
     _fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -95,7 +119,91 @@ instance StrEncoding ServerStatsData where
     _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
     _msgSent <- "msgSent=" *> strP <* A.endOfLine
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    _dayMsgQueues <- "dayMsgQueues=" *> strP <* A.endOfLine
-    _weekMsgQueues <- "weekMsgQueues=" *> strP <* A.endOfLine
-    _monthMsgQueues <- "monthMsgQueues=" *> strP <* optional A.endOfLine
-    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
+    _msgSentNtf <- "msgSentNtf=" *> strP <* A.endOfLine <|> pure 0
+    _msgRecvNtf <- "msgRecvNtf=" *> strP <* A.endOfLine <|> pure 0
+    _activeQueues <-
+      optional ("activeQueues:" <* A.endOfLine) >>= \case
+        Just _ -> strP <* optional A.endOfLine
+        _ -> do
+          _day <- "dayMsgQueues=" *> strP <* A.endOfLine
+          _week <- "weekMsgQueues=" *> strP <* A.endOfLine
+          _month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
+          pure PeriodStatsData {_day, _week, _month}
+    _activeQueuesNtf <-
+      optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
+        Just _ -> strP <* optional A.endOfLine
+        _ -> pure newPeriodStatsData
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount = 0, _msgCount = 0}
+
+data PeriodStats a = PeriodStats
+  { day :: TVar (Set a),
+    week :: TVar (Set a),
+    month :: TVar (Set a)
+  }
+
+newPeriodStats :: STM (PeriodStats a)
+newPeriodStats = do
+  day <- newTVar S.empty
+  week <- newTVar S.empty
+  month <- newTVar S.empty
+  pure PeriodStats {day, week, month}
+
+data PeriodStatsData a = PeriodStatsData
+  { _day :: Set a,
+    _week :: Set a,
+    _month :: Set a
+  }
+  deriving (Show)
+
+newPeriodStatsData :: PeriodStatsData a
+newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty}
+
+getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
+getPeriodStatsData s = do
+  _day <- readTVar $ day s
+  _week <- readTVar $ week s
+  _month <- readTVar $ month s
+  pure PeriodStatsData {_day, _week, _month}
+
+setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
+setPeriodStats s d = do
+  writeTVar (day s) $! _day d
+  writeTVar (week s) $! _week d
+  writeTVar (month s) $! _month d
+
+instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
+  strEncode PeriodStatsData {_day, _week, _month} =
+    "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
+  strP = do
+    _day <- "day=" *> strP <* A.endOfLine
+    _week <- "week=" *> strP <* A.endOfLine
+    _month <- "month=" *> strP
+    pure PeriodStatsData {_day, _week, _month}
+
+data PeriodStatCounts = PeriodStatCounts
+  { dayCount :: String,
+    weekCount :: String,
+    monthCount :: String
+  }
+
+periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
+periodStatCounts ps ts = do
+  let d = utctDay ts
+      (_, wDay) = mondayStartWeek d
+      MonthDay _ mDay = d
+  dayCount <- periodCount 1 $ day ps
+  weekCount <- periodCount wDay $ week ps
+  monthCount <- periodCount mDay $ month ps
+  pure PeriodStatCounts {dayCount, weekCount, monthCount}
+  where
+    periodCount :: Int -> TVar (Set a) -> STM String
+    periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
+    periodCount _ _ = pure ""
+
+updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
+updatePeriodStats stats pId = do
+  updatePeriod day
+  updatePeriod week
+  updatePeriod month
+  where
+    updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)

src/Simplex/Messaging/Server/StoreLog.hs

@@ -17,6 +17,7 @@ module Simplex.Messaging.Server.StoreLog
     logCreateQueue,
     logSecureQueue,
     logAddNotifier,
+    logSuspendQueue,
     logDeleteQueue,
     logDeleteNotifier,
     readWriteStoreLog,
@@ -36,8 +37,8 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), QueueStatus (..))
-import Simplex.Messaging.Transport (trimCR)
+import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
+import Simplex.Messaging.Transport.Buffer (trimCR)
 import System.Directory (doesFileExist)
 import System.IO
 
@@ -51,6 +52,7 @@ data StoreLogRecord
   = CreateQueue QueueRec
   | SecureQueue QueueId SndPublicVerifyKey
   | AddNotifier QueueId NtfCreds
+  | SuspendQueue QueueId
   | DeleteQueue QueueId
   | DeleteNotifier QueueId
 
@@ -81,6 +83,7 @@ instance StrEncoding StoreLogRecord where
     CreateQueue q -> strEncode (Str "CREATE", q)
     SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)
     AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds)
+    SuspendQueue rId -> strEncode (Str "SUSPEND", rId)
     DeleteQueue rId -> strEncode (Str "DELETE", rId)
     DeleteNotifier rId -> strEncode (Str "NDELETE", rId)
 
@@ -88,6 +91,7 @@ instance StrEncoding StoreLogRecord where
     "CREATE " *> (CreateQueue <$> strP)
       <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
       <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP)
+      <|> "SUSPEND " *> (SuspendQueue <$> strP)
       <|> "DELETE " *> (DeleteQueue <$> strP)
       <|> "NDELETE " *> (DeleteNotifier <$> strP)
 
@@ -126,6 +130,9 @@ logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
 logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO ()
 logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds
 
+logSuspendQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
+logSuspendQueue s = writeStoreLogRecord s . SuspendQueue
+
 logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 
@@ -161,6 +168,7 @@ readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLo
       CreateQueue q -> M.insert (recipientId q) q m
       SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
       AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
+      SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
       DeleteQueue qId -> M.delete qId m
       DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
     printError :: LogParsingError -> IO ()

src/Simplex/Messaging/TMap.hs

@@ -2,6 +2,7 @@ module Simplex.Messaging.TMap
   ( TMap,
     empty,
     singleton,
+    clear,
     Simplex.Messaging.TMap.null,
     Simplex.Messaging.TMap.lookup,
     member,
@@ -31,6 +32,10 @@ singleton :: k -> a -> STM (TMap k a)
 singleton k v = newTVar $ M.singleton k v
 {-# INLINE singleton #-}
 
+clear :: TMap k a -> STM ()
+clear m = writeTVar m M.empty
+{-# INLINE clear #-}
+
 null :: TMap k a -> STM Bool
 null m = M.null <$> readTVar m
 {-# INLINE null #-}

src/Simplex/Messaging/Transport.hs

@@ -28,6 +28,7 @@ module Simplex.Messaging.Transport
   ( -- * SMP transport parameters
     supportedSMPServerVRange,
     simplexMQVersion,
+    smpBlockSize,
 
     -- * Transport connection class
     Transport (..),
@@ -55,9 +56,6 @@ module Simplex.Messaging.Transport
     transportErrorP,
     sendHandshake,
     getHandshake,
-
-    -- * Trim trailing CR
-    trimCR,
   )
 where
 
@@ -74,15 +72,18 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as BL
 import Data.Default (def)
 import Data.Functor (($>))
+import Data.Version (showVersion)
 import GHC.Generics (Generic)
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Generic.Random (genericArbitraryU)
 import Network.Socket
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
+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 (..))
@@ -96,10 +97,10 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 3
+supportedSMPServerVRange = mkVersionRange 1 5
 
 simplexMQVersion :: String
-simplexMQVersion = "3.0.0"
+simplexMQVersion = showVersion SMQ.version
 
 -- * Transport connection class
 
@@ -149,24 +150,24 @@ data TLS = TLS
   { tlsContext :: T.Context,
     tlsPeer :: TransportPeer,
     tlsUniq :: ByteString,
-    buffer :: TVar ByteString,
-    getLock :: TMVar ()
+    tlsBuffer :: TBuffer
   }
 
-connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context
-connectTLS params sock =
-  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do
-    T.handshake ctx
-      `catchAll` \e -> putStrLn ("exception: " <> show e) >> E.throwIO e
-    pure ctx
+connectTLS :: T.TLSParams p => Maybe HostName -> Bool -> p -> Socket -> IO T.Context
+connectTLS host_ logErrors params sock =
+  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
+    logHandshakeErrors (T.handshake ctx) $> ctx
+  where
+    logHandshakeErrors = if logErrors then (`catchAll` logThrow) else id
+    logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
+    host = maybe "" (\h -> " (" <> h <> ")") host_
 
 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 =
@@ -204,52 +205,22 @@ instance Transport TLS where
   closeConnection tls = closeTLS $ tlsContext tls
 
   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 = do
+    s <- getBuffered tlsBuffer n (T.recvData tlsContext)
+    -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
+    if B.length s == n then pure s else ioe_EOF
 
   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 .
@@ -258,7 +229,10 @@ data THandle c = THandle
     sessionId :: SessionId,
     blockSize :: Int,
     -- | agreed server protocol version
-    thVersion :: Version
+    thVersion :: Version,
+    -- | send multiple transmissions in a single block
+    -- based on protocol and protocol version
+    batch :: Bool
   }
 
 -- | TLS-unique channel binding
@@ -329,7 +303,7 @@ transportErrorP =
   "BLOCK" $> TEBadBlock
     <|> "LARGE_MSG" $> TELargeMsg
     <|> "SESSION" $> TEBadSession
-    <|> TEHandshake <$> parseRead1
+    <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
 
 -- | Serialize SMP encrypted transport error.
 serializeTransportError :: TransportError -> ByteString
@@ -337,7 +311,7 @@ serializeTransportError = \case
   TEBadBlock -> "BLOCK"
   TELargeMsg -> "LARGE_MSG"
   TEBadSession -> "SESSION"
-  TEHandshake e -> bshow e
+  TEHandshake e -> "HANDSHAKE " <> bshow e
 
 -- | Pad and send block to SMP transport.
 tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
@@ -364,7 +338,7 @@ smpServerHandshake c kh smpVRange = do
       | keyHash /= kh ->
         throwE $ TEHandshake IDENTITY
       | smpVersion `isCompatible` smpVRange -> do
-        pure (th :: THandle c) {thVersion = smpVersion}
+        pure $ smpThHandle th smpVersion
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | Client SMP transport handshake.
@@ -379,9 +353,12 @@ smpClientHandshake c keyHash smpVRange = do
     else case smpVersionRange `compatibleVersion` smpVRange of
       Just (Compatible smpVersion) -> do
         sendHandshake th $ ClientHandshake {smpVersion, keyHash}
-        pure (th :: THandle c) {thVersion = smpVersion}
+        pure $ smpThHandle th smpVersion
       Nothing -> throwE $ TEHandshake VERSION
 
+smpThHandle :: forall c. THandle c -> Version -> THandle c
+smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
+
 sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
 sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
@@ -389,4 +366,4 @@ getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportErr
 getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
 
 smpTHandle :: Transport c => c -> THandle c
-smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0}
+smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}

src/Simplex/Messaging/Transport/Buffer.hs

@@ -0,0 +1,61 @@
+{-# 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'
+  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

@@ -1,43 +1,139 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Transport.Client
   ( runTransportClient,
     runTLSTransportClient,
     smpClientHandshake,
+    defaultSMPPort,
+    defaultTransportClientConfig,
+    defaultSocksProxy,
+    TransportClientConfig (..),
+    SocksProxy,
+    TransportHost (..),
+    TransportHosts (..),
+    TransportHosts_ (..),
   )
 where
 
+import Control.Applicative (optional)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
+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
+import Data.Maybe (fromMaybe)
+import Data.String
+import Data.Word (Word8)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import GHC.IO.Exception (IOErrorType (..))
 import Network.Socket
+import Network.Socks5
 import qualified Network.TLS as T
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
+import Simplex.Messaging.Util (bshow, (<$?>))
 import System.IO.Error
+import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
 
+data TransportHost
+  = THIPv4 (Word8, Word8, Word8, Word8)
+  | THOnionHost ByteString
+  | THDomainName HostName
+  deriving (Eq, Ord, Show)
+
+instance Encoding TransportHost where
+  smpEncode = smpEncode . strEncode
+  smpP = parseAll strP <$?> smpP
+
+instance StrEncoding TransportHost where
+  strEncode = \case
+    THIPv4 (a1, a2, a3, a4) -> B.intercalate "." $ map bshow [a1, a2, a3, a4]
+    THOnionHost host -> host
+    THDomainName host -> B.pack host
+  strP =
+    A.choice
+      [ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
+        THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
+        THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
+      ]
+    where
+      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
+  toJSON = strToJSON
+
+newtype TransportHosts = TransportHosts {thList :: NonEmpty TransportHost}
+
+instance StrEncoding TransportHosts where
+  strEncode = strEncodeList . L.toList . thList
+  strP = TransportHosts . L.fromList <$> strP `A.sepBy1'` A.char ','
+
+newtype TransportHosts_ = TransportHosts_ {thList_ :: [TransportHost]}
+
+instance StrEncoding TransportHosts_ where
+  strEncode = strEncodeList . thList_
+  strP = TransportHosts_ <$> strP `A.sepBy'` A.char ','
+
+instance IsString TransportHost where fromString = parseString strDecode
+
+instance IsString (NonEmpty TransportHost) where fromString = parseString strDecode
+
+data TransportClientConfig = TransportClientConfig
+  { socksProxy :: Maybe SocksProxy,
+    tcpKeepAlive :: Maybe KeepAliveOpts,
+    logTLSErrors :: Bool
+  }
+  deriving (Eq, Show)
+
+defaultTransportClientConfig :: TransportClientConfig
+defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
+
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: (Transport c, MonadUnliftIO m) => HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
-runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ host port keyHash keepAliveOpts client = do
-  let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash
-  c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
+runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
+runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} proxyUsername host port keyHash client = do
+  let hostName = B.unpack $ strEncode host
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
+      connectTCP = case socksProxy of
+        Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
+        _ -> connectTCPClient hostName
+  c <- liftIO $ do
+    sock <- connectTCP port
+    mapM_ (setSocketKeepAlive sock) tcpKeepAlive
+    connectTLS (Just hostName) logTLSErrors clientParams sock >>= getClientConnection
   client c `E.finally` liftIO (closeConnection c)
+  where
+    hostAddr = \case
+      THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
+      THOnionHost h -> SocksAddrDomainName h
+      THDomainName h -> SocksAddrDomainName $ B.pack h
 
-startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
-startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
+connectTCPClient :: HostName -> ServiceName -> IO Socket
+connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -47,20 +143,54 @@ startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>
       let hints = defaultHints {addrSocketType = Stream}
        in getAddrInfo (Just hints) (Just host) (Just port)
 
-    tryOpen :: IOException -> [AddrInfo] -> IO c
+    tryOpen :: IOException -> [AddrInfo] -> IO Socket
     tryOpen e [] = E.throwIO e
     tryOpen _ (addr : as) =
       E.try (open addr) >>= either (`tryOpen` as) pure
 
-    open :: AddrInfo -> IO c
+    open :: AddrInfo -> IO Socket
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      mapM_ (setSocketKeepAlive sock) keepAliveOpts
-      ctx <- connectTLS clientParams sock
-      getClientConnection ctx
+      pure sock
 
--- readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
+defaultSMPPort :: PortNumber
+defaultSMPPort = 5223
+
+connectSocksClient :: SocksProxy -> Maybe ByteString -> SocksHostAddress -> ServiceName -> IO Socket
+connectSocksClient (SocksProxy addr) proxyUsername hostAddr _port = do
+  let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
+  fst <$> case proxyUsername of
+    Just username -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) (SocksCredentials username "")
+    _ -> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
+
+defaultSocksHost :: HostAddress
+defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
+
+defaultSocksProxy :: SocksProxy
+defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
+
+newtype SocksProxy = SocksProxy SockAddr
+  deriving (Eq)
+
+instance Show SocksProxy where show (SocksProxy addr) = show addr
+
+instance StrEncoding SocksProxy where
+  strEncode = B.pack . show
+  strP = do
+    host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
+    port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
+    pure . SocksProxy $ SockAddrInet port host
+    where
+      ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
+      ipNum = A.decimal <* A.char '.'
+
+instance ToJSON SocksProxy where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON SocksProxy where
+  parseJSON = strParseJSON "SocksProxy"
 
 mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
 mkTLSClientParams supported caStore_ host port keyHash_ = do

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,29 +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 Simplex.Messaging.Transport.Client (runTLSTransportClient)
-import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
-import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
+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
 import UnliftIO.STM
 import UnliftIO.Timeout
 
 data HTTP2Client = HTTP2Client
-  { action :: 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)
@@ -36,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,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    caStoreFile :: FilePath,
+    transportConfig :: TransportClientConfig,
+    bufferSize :: BufferSize,
+    bodyHeadSize :: Int,
     suportedTLSParams :: T.Supported
   }
   deriving (Show)
@@ -54,75 +65,90 @@ defaultHTTP2ClientConfig =
   HTTP2ClientConfig
     { qSize = 64,
       connTimeout = 10000000,
-      tcpKeepAlive = Nothing,
-      caStoreFile = "/etc/ssl/cert.pem",
+      transportConfig = TransportClientConfig Nothing Nothing True,
+      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 {tcpKeepAlive, 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 = undefined, 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 host port tcpKeepAlive (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}
+      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 ()
--- TODO disconnect
-closeHTTP2Client = uninterruptibleCancel . action
+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 -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
-runHTTP2Client tlsParams caStore host port keepAliveOpts client =
-  runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \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,33 +6,35 @@ 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,
-    certificateFile :: FilePath
+    certificateFile :: FilePath,
+    logTLSErrors :: Bool
   }
   deriving (Show)
 
 data HTTP2Request = HTTP2Request
-  { request :: Request,
-    reqBody :: ByteString,
-    reqTrailers :: Maybe HeaderTable,
+  { sessionId :: SessionId,
+    request :: Request,
+    reqBody :: HTTP2Body,
     sendResponse :: Response -> IO ()
   }
 
@@ -41,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} = 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 $ \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 -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port serverParams http2Server =
-  runTransportServer started port serverParams $ \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` [])