4.2.3

* do not show warning on server restart when restoring "quota" message and quota is exceeded

* complete case

* line break

.github/workflows/build.yml

@@ -11,35 +11,51 @@ 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
 
       - 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 +66,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,7 +75,7 @@ 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

.gitignore

@@ -5,4 +5,5 @@
 tests/tmp
 dist-newstyle/
 
-src/tor
+cabal.project.local
+cabal.project.local~

CHANGELOG.md

@@ -1,3 +1,87 @@
+# 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:

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.1.1",
-          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 #-}
 
@@ -8,6 +9,7 @@ import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
 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
@@ -17,7 +19,8 @@ servers :: InitialAgentServers
 servers =
   InitialAgentServers
     { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = []
+      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,84 +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")
-              <> "# 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: " <> (if enableStoreLog then "on" else "off") <> "\n")
-              <> ("log_stats: 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 ->
-            let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
-                logStats = settingIsOn "STORE_LOG" "log_stats"
-             in 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 =
-                      settingIsOn "INACTIVE_CLIENTS" "disconnect"
-                        $> 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
-                  }
-        }
+  setLogLevel LogDebug
+  withGlobalLogging logCfg $ smpServerCLI cfgPath logPath

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,17 @@
 packages: .
+-- packages: . ../direct-sqlcipher ../sqlcipher-simple
 
 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/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.1.0
+version: 4.2.3
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -38,24 +38,25 @@ 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.*
   - 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.*
   - text == 1.2.*
@@ -120,6 +121,8 @@ tests:
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
       - QuickCheck == 2.14.*
+      - silently == 1.2.*
+      - main-tester == 0.2.*
       - timeit == 2.0.*
 
 ghc-options:

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

@@ -0,0 +1,156 @@
+# 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 cryptobox),
+- split into fixed size chunks
+- upload each chunk to a randomly chosen server.
+
+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).
+
+To reduce the size, chunk descriptions will be grouped by the server host.
+
+This "file description" itself will be sent as a small file. To estimate its size:
+
+- each chunk \* redundancy per chunk, assuming chunks are grouped per server:
+  - 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
+- 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 ~34kb (`128 * (8 + 32 + 64) * 2 * 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://abc=@example1.com
+    chunks: [1:abc=:def=, 3:abc=:def=]
+  - server: xftp://abc=@example2.com
+    chunks: [2:abc=:def=, 4:abc=:def=]
+  - server: xftp://abc=@example3.com
+    chunks: [1:abc=:def=, 4:abc=:def=]
+  - server: xftp://abc=@example4.com
+    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/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.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        3.1.0
+version:        4.2.3
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -37,6 +37,7 @@ library
       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,6 +51,11 @@ 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.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
@@ -60,7 +66,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 +79,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
@@ -111,23 +120,24 @@ 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.*
+    , 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.*
     , text ==1.2.*
@@ -142,9 +152,9 @@ library
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable ntf-server
   main-is: Main.hs
@@ -171,24 +181,25 @@ 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.*
+    , 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.*
@@ -203,9 +214,9 @@ executable ntf-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable smp-agent
   main-is: Main.hs
@@ -232,24 +243,25 @@ 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.*
+    , 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.*
@@ -264,9 +276,9 @@ executable smp-agent
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 executable smp-server
   main-is: Main.hs
@@ -293,24 +305,25 @@ 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.*
+    , 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.*
@@ -325,9 +338,9 @@ executable smp-server
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010
 
 test-suite smp-server-test
   type: exitcode-stdio-1.0
@@ -340,8 +353,11 @@ test-suite smp-server-test
       AgentTests.NotificationTests
       AgentTests.SchemaDump
       AgentTests.SQLiteTests
+      CLITests
+      CoreTests.CryptoTests
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
+      CoreTests.RetryIntervalTests
       CoreTests.VersionRangeTests
       NtfClient
       NtfServerTests
@@ -371,7 +387,7 @@ 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
@@ -379,18 +395,21 @@ test-suite smp-server-test
     , hspec-core ==2.7.*
     , http-types ==0.12.*
     , http2 ==3.0.*
-    , ini ==0.4.*
+    , 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.*
@@ -406,6 +425,6 @@ test-suite smp-server-test
     , x509 ==1.7.*
     , x509-store ==1.6.*
     , x509-validation ==1.6.*
+  default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
-  default-language: Haskell2010

src/Simplex/Messaging/Agent/Client.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -16,9 +17,13 @@
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
+    SMPTestFailure (..),
+    SMPTestStep (..),
     newAgentClient,
-    withAgentLock,
+    withConnLock,
     closeAgentClient,
+    closeProtocolServerClients,
+    runSMPServerTest,
     newRcvQueue,
     subscribeQueue,
     subscribeQueues,
@@ -28,7 +33,8 @@ module Simplex.Messaging.Agent.Client
     getSubscriptions,
     sendConfirmation,
     sendInvitation,
-    RetryInterval (..),
+    temporaryAgentError,
+    temporaryOrHostError,
     secureQueue,
     enableQueueNotifications,
     disableQueueNotifications,
@@ -49,14 +55,20 @@ module Simplex.Messaging.Agent.Client
     suspendQueue,
     deleteQueue,
     logServer,
+    logSecret,
     removeSubscription,
     hasActiveSubscription,
-    agentDbPath,
+    agentClientStore,
     AgentOperation (..),
     AgentOpState (..),
     AgentState (..),
+    AgentLocks (..),
+    AgentStatsKey (..),
     agentOperations,
     agentOperationBracket,
+    waitUntilActive,
+    throwWhenInactive,
+    throwWhenNoDelivery,
     beginAgentOperation,
     endAgentOperation,
     suspendSendingAndDatabase,
@@ -69,45 +81,78 @@ module Simplex.Messaging.Agent.Client
   )
 where
 
-import Control.Concurrent (forkIO)
+import Control.Applicative ((<|>))
+import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (retry, stateTVar)
+import Control.Concurrent.STM (retry, stateTVar, throwSTM)
+import Control.Exception (AsyncException (..))
 import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as J
 import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (partitionEithers)
-import Data.List.NonEmpty (NonEmpty)
+import Data.Either (isRight, partitionEithers)
+import Data.Functor (($>))
+import Data.List (partition)
+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.Maybe (listToMaybe)
+import Data.Maybe (isJust, listToMaybe)
 import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text.Encoding
-import Data.Tuple (swap)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
+import GHC.Generics (Generic)
+import Network.Socket (HostName)
 import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
+import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues)
+import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, NtfServer, ProtoServer, ProtocolServer (..), QueueId, QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, SMPMsgMeta (..), SndPublicVerifyKey)
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parse)
+import Simplex.Messaging.Protocol
+  ( AProtocolType (..),
+    BrokerMsg,
+    ErrorType,
+    MsgFlags (..),
+    MsgId,
+    NotifierId,
+    NtfPrivateSignKey,
+    NtfPublicVerifyKey,
+    NtfServer,
+    ProtoServer,
+    Protocol (..),
+    ProtocolServer (..),
+    ProtocolTypeI (..),
+    QueueId,
+    QueueIdsKeys (..),
+    RcvMessage (..),
+    RcvNtfPublicDhKey,
+    SMPMsgMeta (..),
+    SndPublicVerifyKey,
+  )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Timeout (timeout)
@@ -126,16 +171,20 @@ data AgentClient = AgentClient
     rcvQ :: TBQueue (ATransmission 'Client),
     subQ :: TBQueue (ATransmission 'Agent),
     msgQ :: TBQueue (ServerTransmission BrokerMsg),
-    smpServers :: TVar (NonEmpty SMPServer),
+    smpServers :: TVar (NonEmpty SMPServerWithAuth),
     smpClients :: TMap SMPServer SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfServer NtfClientVar,
-    subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
-    pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
-    subscrConns :: TMap ConnId SMPServer,
-    connMsgsQueued :: TMap ConnId Bool,
-    smpQueueMsgQueues :: TMap (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId),
-    smpQueueMsgDeliveries :: TMap (ConnId, SMPServer, SMP.SenderId) (Async ()),
+    useNetworkConfig :: TVar NetworkConfig,
+    subscrConns :: TVar (Set ConnId),
+    activeSubs :: TRcvQueues,
+    pendingSubs :: TRcvQueues,
+    pendingMsgsQueued :: TMap SndQAddr Bool,
+    smpQueueMsgQueues :: TMap SndQAddr (TQueue InternalId, TMVar ()),
+    smpQueueMsgDeliveries :: TMap SndQAddr (Async ()),
+    connCmdsQueued :: TMap ConnId Bool,
+    asyncCmdQueues :: TMap (Maybe SMPServer) (TQueue AsyncCmdId),
+    asyncCmdProcesses :: TMap (Maybe SMPServer) (Async ()),
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -143,11 +192,15 @@ data AgentClient = AgentClient
     databaseOp :: TVar AgentOpState,
     agentState :: TVar AgentState,
     getMsgLocks :: TMap (SMPServer, SMP.RecipientId) (TMVar ()),
+    -- locks to prevent concurrent operations with connection
+    connLocks :: TMap ConnId Lock,
+    -- locks to prevent concurrent reconnections to SMP servers
+    reconnectLocks :: TMap SMPServer Lock,
     reconnections :: TVar [Async ()],
     asyncClients :: TVar [Async ()],
+    agentStats :: TMap AgentStatsKey (TVar Int),
     clientId :: Int,
-    agentEnv :: Env,
-    lock :: TMVar ()
+    agentEnv :: Env
   }
 
 data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
@@ -169,8 +222,16 @@ data AgentOpState = AgentOpState {opSuspended :: Bool, opsInProgress :: Int}
 data AgentState = ASActive | ASSuspending | ASSuspended
   deriving (Eq, Show)
 
+data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map String String}
+  deriving (Show, Generic)
+
+instance ToJSON AgentLocks where toEncoding = J.genericToEncoding J.defaultOptions
+
+data AgentStatsKey = AgentStatsKey {host :: ByteString, clientTs :: ByteString, cmd :: ByteString, res :: ByteString}
+  deriving (Eq, Ord, Show)
+
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
-newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
+newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
   active <- newTVar True
   rcvQ <- newTBQueue qSize
@@ -180,12 +241,16 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   smpClients <- TM.empty
   ntfServers <- newTVar ntf
   ntfClients <- TM.empty
-  subscrSrvrs <- TM.empty
-  pendingSubscrSrvrs <- TM.empty
-  subscrConns <- TM.empty
-  connMsgsQueued <- TM.empty
+  useNetworkConfig <- newTVar netCfg
+  subscrConns <- newTVar S.empty
+  activeSubs <- RQ.empty
+  pendingSubs <- RQ.empty
+  pendingMsgsQueued <- TM.empty
   smpQueueMsgQueues <- TM.empty
   smpQueueMsgDeliveries <- TM.empty
+  connCmdsQueued <- TM.empty
+  asyncCmdQueues <- TM.empty
+  asyncCmdProcesses <- TM.empty
   ntfNetworkOp <- newTVar $ AgentOpState False 0
   rcvNetworkOp <- newTVar $ AgentOpState False 0
   msgDeliveryOp <- newTVar $ AgentOpState False 0
@@ -193,14 +258,16 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   databaseOp <- newTVar $ AgentOpState False 0
   agentState <- newTVar ASActive
   getMsgLocks <- TM.empty
+  connLocks <- TM.empty
+  reconnectLocks <- TM.empty
   reconnections <- newTVar []
   asyncClients <- newTVar []
+  agentStats <- TM.empty
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
-  lock <- newTMVar ()
-  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
+  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useNetworkConfig, subscrConns, activeSubs, pendingSubs, pendingMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, connCmdsQueued, asyncCmdQueues, asyncCmdProcesses, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, connLocks, reconnectLocks, reconnections, asyncClients, agentStats, clientId, agentEnv}
 
-agentDbPath :: AgentClient -> FilePath
-agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
+agentClientStore :: AgentClient -> SQLiteStore
+agentClientStore AgentClient {agentEnv = Env {store}} = store
 
 class ProtocolServerClient msg where
   getProtocolServerClient :: AgentMonad m => AgentClient -> ProtoServer msg -> m (ProtocolClient msg)
@@ -220,68 +287,66 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
   atomically (getClientVar srv smpClients)
     >>= either
       (newProtocolClient c srv smpClients connectClient reconnectClient)
-      (waitForProtocolClient smpCfg)
+      (waitForProtocolClient c srv)
   where
     connectClient :: m SMPClient
     connectClient = do
-      cfg <- asks $ smpCfg . config
+      cfg <- getClientConfig c smpCfg
       u <- askUnliftIO
-      liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
+      liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
 
-    clientDisconnected :: UnliftIO m -> IO ()
-    clientDisconnected u = do
-      removeClientAndSubs >>= (`forM_` serverDown u)
+    clientDisconnected :: UnliftIO m -> SMPClient -> IO ()
+    clientDisconnected u client = do
+      removeClientAndSubs >>= serverDown
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
-
-    removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
-    removeClientAndSubs = atomically $ do
-      TM.delete srv smpClients
-      TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
       where
-        updateSubs cVar = do
-          cs <- readTVar cVar
-          modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
-          addPendingSubs cVar cs
-          pure cs
+        removeClientAndSubs :: IO ([RcvQueue], [ConnId])
+        removeClientAndSubs = atomically $ do
+          TM.delete srv smpClients
+          (qs, conns) <- RQ.getDelSrvQueues srv $ activeSubs c
+          mapM_ (`RQ.addQueue` pendingSubs c) qs
+          pure (qs, S.toList conns)
 
-        addPendingSubs cVar cs = do
-          let ps = pendingSubscrSrvrs c
-          TM.lookup srv ps >>= \case
-            Just v -> TM.union cs v
-            _ -> TM.insert srv cVar ps
+        serverDown :: ([RcvQueue], [ConnId]) -> IO ()
+        serverDown (qs, conns) = whenM (readTVarIO active) $ do
+          incClientStat c client "DISCONNECT" ""
+          notifySub "" $ hostEvent DISCONNECT client
+          unless (null conns) $ notifySub "" $ DOWN srv conns
+          unless (null qs) $ do
+            atomically $ mapM_ (releaseGetLock c) qs
+            unliftIO u reconnectServer
 
-    serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
-    serverDown u cs = unless (M.null cs) $
-      whenM (readTVarIO active) $ do
-        let conns = M.keys cs
-        unless (null conns) . notifySub "" $ DOWN srv conns
-        atomically $ mapM_ (releaseGetLock c) cs
-        unliftIO u reconnectServer
+        reconnectServer :: m ()
+        reconnectServer = do
+          a <- async tryReconnectClient
+          atomically $ modifyTVar' (reconnections c) (a :)
 
-    reconnectServer :: m ()
-    reconnectServer = do
-      a <- async tryReconnectClient
-      atomically $ modifyTVar' (reconnections c) (a :)
-
-    tryReconnectClient :: m ()
-    tryReconnectClient = do
-      ri <- asks $ reconnectInterval . config
-      withRetryInterval ri $ \loop ->
-        reconnectClient `catchError` const loop
+        tryReconnectClient :: m ()
+        tryReconnectClient = do
+          ri <- asks $ reconnectInterval . config
+          withRetryInterval ri $ \loop ->
+            reconnectClient `catchError` const loop
 
     reconnectClient :: m ()
     reconnectClient =
-      withAgentLock c $
-        atomically (TM.lookup srv (pendingSubscrSrvrs c) >>= mapM readTVar)
-          >>= mapM_ resubscribe
+      withLockMap_ (reconnectLocks c) srv "reconnect" $
+        atomically (RQ.getSrvQueues srv $ pendingSubs c) >>= resubscribe
       where
-        resubscribe :: Map ConnId RcvQueue -> m ()
+        resubscribe :: [RcvQueue] -> m ()
         resubscribe qs = do
-          (errs, oks) <- M.mapEither id <$> subscribeQueues c srv qs
-          liftIO . unless (M.null oks) . notifySub "" . UP srv $ M.keys oks
-          let (tempErrs, finalErrs) = M.partition temporaryAgentError errs
-          liftIO . mapM_ (\(connId, e) -> notifySub connId $ ERR e) $ M.assocs finalErrs
-          mapM_ throwError . listToMaybe $ M.elems tempErrs
+          connected <- maybe False isRight <$> atomically (TM.lookup srv smpClients $>>= tryReadTMVar)
+          cs <- atomically . RQ.getConns $ activeSubs c
+          (client_, rs) <- subscribeQueues c srv qs
+          let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
+          liftIO $ do
+            unless connected . forM_ client_ $ \cl -> do
+              incClientStat c cl "CONNECT" ""
+              notifySub "" $ hostEvent CONNECT cl
+            let conns = S.toList $ S.fromList okConns `S.difference` cs
+            unless (null conns) $ notifySub "" $ UP srv conns
+          let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
+          liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
+          mapM_ (throwError . snd) $ listToMaybe tempErrs
 
     notifySub :: ConnId -> ACommand 'Agent -> IO ()
     notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
@@ -292,16 +357,18 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
   atomically (getClientVar srv ntfClients)
     >>= either
       (newProtocolClient c srv ntfClients connectClient $ pure ())
-      (waitForProtocolClient ntfCfg)
+      (waitForProtocolClient c srv)
   where
     connectClient :: m NtfClient
     connectClient = do
-      cfg <- asks $ ntfCfg . config
-      liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
+      cfg <- getClientConfig c ntfCfg
+      liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient srv cfg Nothing clientDisconnected)
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: NtfClient -> IO ()
+    clientDisconnected client = do
       atomically $ TM.delete srv ntfClients
+      incClientStat c client "DISCONNECT" ""
+      atomically $ writeTBQueue (subQ c) ("", "", hostEvent DISCONNECT client)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 getClientVar :: forall a s. ProtocolServer s -> TMap (ProtocolServer s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
@@ -313,18 +380,18 @@ getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.l
       TM.insert srv var clients
       pure var
 
-waitForProtocolClient :: AgentMonad m => (AgentConfig -> ProtocolClientConfig) -> ClientVar msg -> m (ProtocolClient msg)
-waitForProtocolClient clientConfig clientVar = do
-  ProtocolClientConfig {tcpTimeout} <- asks $ clientConfig . config
-  client_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar clientVar)
+waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> ProtoServer msg -> ClientVar msg -> m (ProtocolClient msg)
+waitForProtocolClient c srv clientVar = do
+  NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
+  client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
   liftEither $ case client_ of
     Just (Right smpClient) -> Right smpClient
     Just (Left e) -> Left e
-    Nothing -> Left $ BROKER TIMEOUT
+    Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
 
 newProtocolClient ::
   forall msg m.
-  AgentMonad m =>
+  (AgentMonad m, ProtocolTypeI (ProtoType msg)) =>
   AgentClient ->
   ProtoServer msg ->
   TMap (ProtoServer msg) (ClientVar msg) ->
@@ -340,9 +407,12 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
         Right client -> do
           logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
           atomically $ putTMVar clientVar r
+          liftIO $ incClientStat c client "CLIENT" "OK"
+          atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client)
           successAction client
         Left e -> do
-          if e == BROKER NETWORK || e == BROKER TIMEOUT
+          liftIO $ incServerStat c srv "CLIENT" $ strEncode e
+          if temporaryAgentError e
             then retryAction
             else atomically $ do
               putTMVar clientVar (Left e)
@@ -357,125 +427,199 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
 
+hostEvent :: forall msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent
+hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client
+
+getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
+getClientConfig AgentClient {useNetworkConfig} cfgSel = do
+  cfg <- asks $ cfgSel . config
+  networkConfig <- readTVarIO useNetworkConfig
+  pure cfg {networkConfig}
+
 closeAgentClient :: MonadIO m => AgentClient -> m ()
 closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
-  closeProtocolServerClients (clientTimeout smpCfg) $ smpClients c
-  closeProtocolServerClients (clientTimeout ntfCfg) $ ntfClients c
+  closeProtocolServerClients c smpClients
+  closeProtocolServerClients c ntfClients
   cancelActions $ reconnections c
   cancelActions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
-  clear subscrSrvrs
-  clear pendingSubscrSrvrs
+  cancelActions $ asyncCmdProcesses c
+  atomically . RQ.clear $ activeSubs c
+  atomically . RQ.clear $ pendingSubs c
   clear subscrConns
-  clear connMsgsQueued
+  clear pendingMsgsQueued
   clear smpQueueMsgQueues
+  clear connCmdsQueued
+  clear asyncCmdQueues
   clear getMsgLocks
   where
-    clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
-    clear :: (AgentClient -> TMap k a) -> IO ()
-    clear sel = atomically $ writeTVar (sel c) M.empty
+    clear :: Monoid m => (AgentClient -> TVar m) -> IO ()
+    clear sel = atomically $ writeTVar (sel c) mempty
 
-closeProtocolServerClients :: Int -> TMap (ProtoServer msg) (ClientVar msg) -> IO ()
-closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+waitUntilActive :: AgentClient -> STM ()
+waitUntilActive c = unlessM (readTVar $ active c) retry
+
+throwWhenInactive :: AgentClient -> STM ()
+throwWhenInactive c = unlessM (readTVar $ active c) $ throwSTM ThreadKilled
+
+throwWhenNoDelivery :: AgentClient -> SndQueue -> STM ()
+throwWhenNoDelivery c SndQueue {server, sndId} =
+  unlessM (isJust <$> TM.lookup k (smpQueueMsgQueues c)) $ do
+    TM.delete k $ smpQueueMsgDeliveries c
+    throwSTM ThreadKilled
   where
-    closeClient cVar =
-      tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
+    k = (server, sndId)
+
+closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO ()
+closeProtocolServerClients c clientsSel =
+  readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+  where
+    cs = clientsSel c
+    closeClient cVar = do
+      NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
+      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
         _ -> pure ()
 
 cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel >> atomically (writeTVar as mempty)
+cancelActions as = readTVarIO as >>= mapM_ (forkIO . uninterruptibleCancel) >> atomically (writeTVar as mempty)
 
-withAgentLock :: MonadUnliftIO m => AgentClient -> m a -> m a
-withAgentLock AgentClient {lock} =
-  E.bracket_
-    (void . atomically $ takeTMVar lock)
-    (atomically $ putTMVar lock ())
+withConnLock :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m a -> m a
+withConnLock _ "" _ = id
+withConnLock AgentClient {connLocks} connId name = withLockMap_ connLocks connId name
 
-withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> (ProtocolClient msg -> m a) -> m a
-withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchError` logServerError
+withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
+withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pure
   where
-    logServerError :: AgentErrorType -> m a
-    logServerError e = do
-      logServer "<--" c srv "" $ bshow e
+    newLock = newEmptyTMVar >>= \l -> TM.insert key l locks $> l
+
+withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withClient_ c srv statCmd action = do
+  cl <- getProtocolServerClient c srv
+  (action cl <* stat cl "OK") `catchError` logServerError cl
+  where
+    stat cl = liftIO . incClientStat c cl statCmd
+    logServerError :: ProtocolClient msg -> AgentErrorType -> m a
+    logServerError cl e = do
+      logServer "<--" c srv "" $ strEncode e
+      stat cl $ strEncode e
       throwError e
 
 withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
 withLogClient_ c srv qId cmdStr action = do
   logServer "-->" c srv qId cmdStr
-  res <- withClient_ c srv action
+  res <- withClient_ c srv cmdStr action
   logServer "<--" c srv qId "OK"
   return res
 
-withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withClient c srv action = withClient_ c srv $ liftClient (clientProtocolError @msg) . action
+withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> ProtoServer msg -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withClient c srv statKey action = withClient_ c srv statKey $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client
 
-withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
-withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (clientProtocolError @msg) . action
+withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg, ProtocolTypeI (ProtoType msg)) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client
 
-liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
-liftClient = liftError . protocolClientError
+liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> HostName -> ExceptT ProtocolClientError IO a -> m a
+liftClient protocolError_ = liftError . protocolClientError protocolError_
 
-protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> AgentErrorType
-protocolClientError protocolError_ = \case
+protocolClientError :: (ErrorType -> AgentErrorType) -> HostName -> ProtocolClientError -> AgentErrorType
+protocolClientError protocolError_ host = \case
   PCEProtocolError e -> protocolError_ e
-  PCEResponseError e -> BROKER $ RESPONSE e
-  PCEUnexpectedResponse _ -> BROKER UNEXPECTED
-  PCEResponseTimeout -> BROKER TIMEOUT
-  PCENetworkError -> BROKER NETWORK
-  PCETransportError e -> BROKER $ TRANSPORT e
+  PCEResponseError e -> BROKER host $ RESPONSE e
+  PCEUnexpectedResponse _ -> BROKER host UNEXPECTED
+  PCEResponseTimeout -> BROKER host TIMEOUT
+  PCENetworkError -> BROKER host NETWORK
+  PCEIncompatibleHost -> BROKER host HOST
+  PCETransportError e -> BROKER host $ TRANSPORT e
   e@PCESignatureError {} -> INTERNAL $ show e
   e@PCEIOError {} -> INTERNAL $ show e
 
-newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
-newRcvQueue c srv =
-  asks (cmdSignAlg . config) >>= \case
-    C.SignAlg a -> newRcvQueue_ a c srv
+data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
+  deriving (Eq, Show, Generic)
 
-newRcvQueue_ ::
-  (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>
-  C.SAlgorithm a ->
-  AgentClient ->
-  SMPServer ->
-  m (RcvQueue, SMPQueueUri)
-newRcvQueue_ a c srv = do
+instance ToJSON SMPTestStep where
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TS"
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "TS"
+
+data SMPTestFailure = SMPTestFailure
+  { testStep :: SMPTestStep,
+    testError :: AgentErrorType
+  }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON SMPTestFailure where
+  toEncoding = J.genericToEncoding J.defaultOptions
+  toJSON = J.genericToJSON J.defaultOptions
+
+runSMPServerTest :: AgentMonad m => AgentClient -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
+runSMPServerTest c (ProtoServerWithAuth srv auth) = do
+  cfg <- getClientConfig c smpCfg
+  C.SignAlg a <- asks $ cmdSignAlg . config
+  liftIO $ do
+    getProtocolClient srv cfg Nothing (\_ -> pure ()) >>= \case
+      Right smp -> do
+        (rKey, rpKey) <- C.generateSignatureKeyPair a
+        (sKey, _) <- C.generateSignatureKeyPair a
+        (dhKey, _) <- C.generateKeyPair'
+        r <- runExceptT $ do
+          SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth
+          liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
+          liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
+        ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
+        incClientStat c smp "TEST" "OK"
+        pure $ either Just (const Nothing) r <|> maybe (Just (SMPTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
+      Left e -> pure (Just $ testErr TSConnect e)
+  where
+    addr = B.unpack $ strEncode srv
+    testErr :: SMPTestStep -> ProtocolClientError -> SMPTestFailure
+    testErr step = SMPTestFailure step . protocolClientError SMP addr
+
+newRcvQueue :: AgentMonad m => AgentClient -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri)
+newRcvQueue c connId (ProtoServerWithAuth srv auth) vRange = do
+  C.SignAlg a <- asks (cmdSignAlg . config)
   (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
   (dhKey, privDhKey) <- liftIO C.generateKeyPair'
   (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   logServer "-->" c srv "" "NEW"
   QIK {rcvId, sndId, rcvPublicDhKey} <-
-    withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
+    withClient c srv "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth
   logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
-          { server = srv,
+          { connId,
+            server = srv,
             rcvId,
             rcvPrivateKey,
             rcvDhSecret = C.dh' rcvPublicDhKey privDhKey,
             e2ePrivKey,
             e2eDhSecret = Nothing,
-            sndId = Just sndId,
+            sndId,
             status = New,
+            dbQueueId = 0,
+            primary = True,
+            dbReplaceQueueId = Nothing,
+            smpClientVersion = maxVersion vRange,
             clientNtfCreds = Nothing
           }
-  pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)
+  pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey)
 
-subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
-subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
+subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
+subscribeQueue c rq@RcvQueue {connId, server, rcvPrivateKey, rcvId} = do
   whenM (atomically . TM.member (server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED
-  atomically $ addPendingSubscription c rq connId
+  atomically $ do
+    modifyTVar' (subscrConns c) $ S.insert connId
+    RQ.addQueue rq $ pendingSubs c
   withLogClient c server rcvId "SUB" $ \smp ->
-    liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq connId)
+    liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq)
       >>= either throwError pure
 
-processSubResult :: AgentClient -> RcvQueue -> ConnId -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
-processSubResult c rq@RcvQueue {server} connId r = do
+processSubResult :: AgentClient -> RcvQueue -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
+processSubResult c rq r = do
   case r of
     Left e ->
       atomically . unless (temporaryClientError e) $
-        removePendingSubscription c server connId
-    _ -> addSubscription c rq connId
+        RQ.deleteQueue rq (pendingSubs c)
+    _ -> addSubscription c rq
   pure r
 
 temporaryClientError :: ProtocolClientError -> Bool
@@ -486,68 +630,62 @@ temporaryClientError = \case
 
 temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
-  BROKER NETWORK -> True
-  BROKER TIMEOUT -> True
+  BROKER _ NETWORK -> True
+  BROKER _ TIMEOUT -> True
   _ -> False
 
+temporaryOrHostError :: AgentErrorType -> Bool
+temporaryOrHostError = \case
+  BROKER _ HOST -> True
+  e -> temporaryAgentError e
+
 -- | subscribe multiple queues - all passed queues should be on the same server
-subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> Map ConnId RcvQueue -> m (Map ConnId (Either AgentErrorType ()))
+subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> [RcvQueue] -> m (Maybe SMPClient, [(RcvQueue, Either AgentErrorType ())])
 subscribeQueues c srv qs = do
-  (errs, qs_) <- partitionEithers <$> mapM checkQueue (M.assocs qs)
-  forM_ qs_ $ atomically . uncurry (addPendingSubscription c) . swap
+  (errs, qs_) <- partitionEithers <$> mapM checkQueue qs
+  forM_ qs_ $ \rq@RcvQueue {connId} -> atomically $ do
+    modifyTVar' (subscrConns c) $ S.insert connId
+    RQ.addQueue rq $ pendingSubs c
   case L.nonEmpty qs_ of
     Just qs' -> do
       smp_ <- tryError (getSMPServerClient c srv)
-      M.fromList . (errs <>) <$> case smp_ of
-        Left e -> pure $ map (second . const $ Left e) qs_
+      (eitherToMaybe smp_,) . (errs <>) <$> case smp_ of
+        Left e -> pure $ map (,Left e) qs_
         Right smp -> do
           logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB"
-          let qs2 = L.map (queueCreds . snd) qs'
-          rs' :: [((ConnId, RcvQueue), Either ProtocolClientError ())] <-
-            liftIO $ zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
-          forM_ rs' $ \((connId, rq), r) -> liftIO $ processSubResult c rq connId r
-          pure $ map (bimap fst (first $ protocolClientError SMP)) rs'
-    _ -> pure $ M.fromList errs
+          let qs2 = L.map queueCreds qs'
+              n = (length qs2 - 1) `div` 90 + 1
+          liftIO $ incClientStatN c smp n "SUBS" "OK"
+          liftIO $ do
+            rs <- zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
+            mapM_ (uncurry $ processSubResult c) rs
+            pure $ map (second . first $ protocolClientError SMP $ clientServer smp) rs
+    _ -> pure (Nothing, errs)
   where
-    checkQueue rq@(connId, RcvQueue {rcvId, server}) = do
-      prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
-      pure $ if prohibited || srv /= server then Left (connId, Left $ CMD PROHIBITED) else Right rq
+    checkQueue rq@RcvQueue {rcvId, server}
+      | server == srv = do
+        prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
+        pure $ if prohibited || srv /= server then Left (rq, Left $ CMD PROHIBITED) else Right rq
+      | otherwise = pure $ Left (rq, Left $ INTERNAL "queue server does not match parameter")
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
 
-addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
-addSubscription c rq@RcvQueue {server} connId = atomically $ do
-  TM.insert connId server $ subscrConns c
-  addSubs_ (subscrSrvrs c) rq connId
-  removePendingSubscription c server connId
+addSubscription :: MonadIO m => AgentClient -> RcvQueue -> m ()
+addSubscription c rq@RcvQueue {connId} = atomically $ do
+  modifyTVar' (subscrConns c) $ S.insert connId
+  RQ.addQueue rq $ activeSubs c
+  RQ.deleteQueue rq $ pendingSubs c
 
 hasActiveSubscription :: AgentClient -> ConnId -> STM Bool
-hasActiveSubscription c connId = TM.member connId (subscrConns c)
-
-addPendingSubscription :: AgentClient -> RcvQueue -> ConnId -> STM ()
-addPendingSubscription = addSubs_ . pendingSubscrSrvrs
-
-addSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> RcvQueue -> ConnId -> STM ()
-addSubs_ ss rq@RcvQueue {server} connId =
-  TM.lookup server ss >>= \case
-    Just m -> TM.insert connId rq m
-    _ -> TM.singleton connId rq >>= \m -> TM.insert server m ss
+hasActiveSubscription c connId = RQ.hasConn connId $ activeSubs c
 
 removeSubscription :: AgentClient -> ConnId -> STM ()
-removeSubscription c@AgentClient {subscrConns} connId = do
-  server_ <- TM.lookupDelete connId subscrConns
-  mapM_ (\server -> removeSubs_ (subscrSrvrs c) server connId) server_
-
-removePendingSubscription :: AgentClient -> SMPServer -> ConnId -> STM ()
-removePendingSubscription = removeSubs_ . pendingSubscrSrvrs
-
-removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> STM ()
-removeSubs_ ss server connId =
-  TM.lookup server ss >>= mapM_ (TM.delete connId)
+removeSubscription c connId = do
+  modifyTVar' (subscrConns c) $ S.delete connId
+  RQ.deleteConn connId $ activeSubs c
+  RQ.deleteConn connId $ pendingSubs c
 
 getSubscriptions :: AgentClient -> STM (Set ConnId)
-getSubscriptions AgentClient {subscrConns} = do
-  m <- readTVar subscrConns
-  pure $ M.keysSet m
+getSubscriptions = readTVar . subscrConns
 
 logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
@@ -555,7 +693,7 @@ logServer dir AgentClient {clientId} srv qId cmdStr =
 
 showServer :: ProtocolServer s -> ByteString
 showServer ProtocolServer {host, port} =
-  B.pack $ host <> if null port then "" else ':' : port
+  strEncode host <> B.pack (if null port then "" else ':' : port)
 
 logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
@@ -565,20 +703,20 @@ sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey,
   withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
     let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
     msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
-    liftClient SMP $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg
+    liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg
 sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
 sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) (Compatible agentVersion) connReq connInfo =
+sendInvitation c (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo =
   withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
     msg <- mkInvitation
-    liftClient SMP $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
+    liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
   where
     mkInvitation :: m ByteString
     -- this is only encrypted with per-queue E2E, not with double ratchet
     mkInvitation = do
       let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
-      agentCbEncryptOnce dhPublicKey . smpEncode $
+      agentCbEncryptOnce v dhPublicKey . smpEncode $
         SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
 
 getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
@@ -643,11 +781,11 @@ sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msgFlags agentMsg
   withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
     let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
     msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
-    liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg
+    liftClient SMP (clientServer smp) $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg
 
 agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
 agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
-  withClient c ntfServer $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
+  withClient c ntfServer "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
 
 agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m ()
 agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
@@ -682,27 +820,25 @@ agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
 
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
-agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
+agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
   cmNonce <- liftIO C.randomCbNonce
   let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey
   cmEncBody <-
     liftEither . first cryptoError $
       C.cbEncrypt e2eDhSecret cmNonce msg paddedLen
-  -- TODO per-queue client version
-  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) e2ePubKey
+  let cmHeader = SMP.PubHeader smpClientVersion e2ePubKey
   pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
 
 -- add encoding as AgentInvitation'?
-agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString
-agentCbEncryptOnce dhRcvPubKey msg = do
+agentCbEncryptOnce :: AgentMonad m => Version -> C.PublicKeyX25519 -> ByteString -> m ByteString
+agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
   (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
   let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
   cmNonce <- liftIO C.randomCbNonce
   cmEncBody <-
     liftEither . first cryptoError $
       C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength
-  -- TODO per-queue client version
-  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) (Just dhSndPubKey)
+  let cmHeader = SMP.PubHeader clientVersion (Just dhSndPubKey)
   pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
 
 -- | NaCl crypto-box decrypt - both for messages received from the server
@@ -773,10 +909,10 @@ beginAgentOperation c op = do
   -- unsafeIOToSTM $ putStrLn $ "beginOperation! " <> show op <> " " <> show (opsInProgress s + 1)
   writeTVar opVar $! s {opsInProgress = opsInProgress s + 1}
 
-agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> m a -> m a
-agentOperationBracket c op action =
+agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> (AgentClient -> STM ()) -> m a -> m a
+agentOperationBracket c op check action =
   E.bracket
-    (atomically $ beginAgentOperation c op)
+    (atomically (check c) >> atomically (beginAgentOperation c op))
     (\_ -> atomically $ endAgentOperation c op)
     (const action)
 
@@ -786,7 +922,7 @@ withStore' c action = withStore c $ fmap Right . action
 withStore :: AgentMonad m => AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
 withStore c action = do
   st <- asks store
-  liftEitherError storeError . agentOperationBracket c AODatabase $
+  liftEitherError storeError . agentOperationBracket c AODatabase (\_ -> pure ()) $
     withTransaction st action `E.catch` handleInternal
   where
     handleInternal :: E.SomeException -> IO (Either StoreError a)
@@ -795,6 +931,7 @@ withStore c action = do
 storeError :: StoreError -> AgentErrorType
 storeError = \case
   SEConnNotFound -> CONN NOT_FOUND
+  SERatchetNotFound -> CONN NOT_FOUND
   SEConnDuplicate -> CONN DUPLICATE
   SEBadConnType CRcv -> CONN SIMPLEX
   SEBadConnType CSnd -> CONN SIMPLEX
@@ -804,3 +941,25 @@ storeError = \case
   -- NOTE: network IO should NOT be used inside AgentStoreMonad
   SEAgentError e -> e
   e -> INTERNAL $ show e
+
+incStat :: AgentClient -> Int -> AgentStatsKey -> STM ()
+incStat AgentClient {agentStats} n k = do
+  TM.lookup k agentStats >>= \case
+    Just v -> modifyTVar' v (+ n)
+    _ -> newTVar n >>= \v -> TM.insert k v agentStats
+
+incClientStat :: AgentClient -> ProtocolClient msg -> ByteString -> ByteString -> IO ()
+incClientStat c pc = incClientStatN c pc 1
+
+incServerStat :: AgentClient -> ProtocolServer p -> ByteString -> ByteString -> IO ()
+incServerStat c ProtocolServer {host} cmd res = do
+  threadDelay 100000
+  atomically $ incStat c 1 statsKey
+  where
+    statsKey = AgentStatsKey {host = strEncode $ L.head host, clientTs = "", cmd, res}
+
+incClientStatN :: AgentClient -> ProtocolClient msg -> Int -> ByteString -> ByteString -> IO ()
+incClientStatN c pc n cmd res = do
+  atomically $ incStat c n statsKey
+  where
+    statsKey = AgentStatsKey {host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res}

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 (..),
   )
@@ -38,11 +43,13 @@ 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,20 +59,32 @@ import UnliftIO.STM
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServer,
-    ntf :: [NtfServer]
+  { smp :: 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,
     ntfCron :: Word16,
     ntfWorkerDelay :: Int,
@@ -75,19 +94,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 v4.6 once most clients are updated
+        -- to resume sending on QCONT messages.
+        -- After that local message expiration period should be also increased.
+        RetryInterval
+          { initialInterval = 10_000000,
+            increaseAfter = 30_000000,
+            maxInterval = 300_000000
+          }
     }
-  where
-    second = 1_000_000
 
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
@@ -96,11 +135,13 @@ 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,
       ntfCron = 20, -- minutes
       ntfWorkerDelay = 100000, -- microseconds
@@ -112,8 +153,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
@@ -126,14 +169,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,24 @@
+{-# 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
+
+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

@@ -55,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 ()
@@ -73,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
@@ -82,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
@@ -162,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 ()
@@ -185,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'
@@ -214,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
@@ -238,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
@@ -260,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'
@@ -275,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
@@ -299,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
 
@@ -345,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/Protocol.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
@@ -32,7 +33,6 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
 module Simplex.Messaging.Agent.Protocol
   ( -- * Protocol parameters
-    currentSMPAgentVersion,
     supportedSMPAgentVRange,
     e2eEncConnInfoLength,
     e2eEncUserMsgLength,
@@ -40,21 +40,36 @@ module Simplex.Messaging.Agent.Protocol
     -- * SMP agent protocol types
     ConnInfo,
     ACommand (..),
+    ACommandTag (..),
+    aCommandTag,
+    ACmd (..),
+    ACmdTag (..),
     AParty (..),
     SAParty (..),
+    APartyI (..),
     MsgHash,
     MsgMeta (..),
+    ConnectionStats (..),
+    SwitchPhase (..),
+    QueueDirection (..),
     SMPConfirmation (..),
     AgentMsgEnvelope (..),
     AgentMessage (..),
     AgentMessageType (..),
     APrivHeader (..),
     AMessage (..),
+    SndQAddr,
     SMPServer,
     pattern SMPServer,
+    pattern ProtoServerWithAuth,
+    SMPServerWithAuth,
     SrvLoc (..),
+    SMPQueue (..),
+    sameQAddress,
+    noAuthSrv,
     SMPQueueUri (..),
     SMPQueueInfo (..),
+    SMPQueueAddress (..),
     ConnectionMode (..),
     SConnectionMode (..),
     AConnectionMode (..),
@@ -64,6 +79,7 @@ module Simplex.Messaging.Agent.Protocol
     ConnectionRequestUri (..),
     AConnectionRequestUri (..),
     ConnReqUriData (..),
+    CRClientData,
     ConnReqScheme (..),
     simplexChat,
     AgentErrorType (..),
@@ -89,11 +105,16 @@ module Simplex.Messaging.Agent.Protocol
     serializeCommand,
     connMode,
     connMode',
+    networkCommandP,
+    dbCommandP,
     commandP,
     connModeT,
     serializeQueueStatus,
     queueStatusT,
     agentMessageType,
+    extraSMPServerHosts,
+    updateSMPServerHosts,
+    checkParty,
 
     -- * TCP transport functions
     tPut,
@@ -112,13 +133,17 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Composition ((.:), (.:.))
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Kind (Type)
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe (isJust)
 import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.Time.ISO8601
@@ -135,18 +160,28 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
-  ( ErrorType,
+  ( AProtocolType,
+    ErrorType,
     MsgBody,
     MsgFlags,
     MsgId,
     NMsgMeta,
+    ProtocolServer (..),
     SMPServer,
+    SMPServerWithAuth,
     SndPublicVerifyKey,
     SrvLoc (..),
+    legacyEncodeServer,
+    legacyServerP,
+    legacyStrEncodeServer,
+    noAuthSrv,
+    sameSrvAddr,
+    pattern ProtoServerWithAuth,
     pattern SMPServer,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
+import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
@@ -197,7 +232,13 @@ instance TestEquality SAParty where
   testEquality SClient SClient = Just Refl
   testEquality _ _ = Nothing
 
-data ACmd = forall p. ACmd (SAParty p) (ACommand p)
+class APartyI (p :: AParty) where sAParty :: SAParty p
+
+instance APartyI Agent where sAParty = SAgent
+
+instance APartyI Client where sAParty = SClient
+
+data ACmd = forall p. APartyI p => ACmd (SAParty p) (ACommand p)
 
 deriving instance Show ACmd
 
@@ -205,28 +246,34 @@ type ConnInfo = ByteString
 
 -- | Parameterized type for SMP agent protocol commands and responses from all participants.
 data ACommand (p :: AParty) where
-  NEW :: AConnectionMode -> ACommand Client -- response INV
+  NEW :: Bool -> AConnectionMode -> ACommand Client -- response INV
   INV :: AConnectionRequestUri -> ACommand Agent
-  JOIN :: AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
-  CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
+  JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
+  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
   LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
-  REQ :: InvitationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
+  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
   ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
   RJCT :: InvitationId -> ACommand Client
   INFO :: ConnInfo -> ACommand Agent
   CON :: ACommand Agent -- notification that connection is established
   SUB :: ACommand Client
   END :: ACommand Agent
+  CONNECT :: AProtocolType -> TransportHost -> ACommand Agent
+  DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent
   DOWN :: SMPServer -> [ConnId] -> ACommand Agent
   UP :: SMPServer -> [ConnId] -> ACommand Agent
+  SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent
   SEND :: MsgFlags -> MsgBody -> ACommand Client
   MID :: AgentMsgId -> ACommand Agent
   SENT :: AgentMsgId -> ACommand Agent
   MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent
   MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent
   ACK :: AgentMsgId -> ACommand Client
+  SWCH :: ACommand Client
   OFF :: ACommand Client
   DEL :: ACommand Client
+  CHK :: ACommand Client
+  STAT :: ConnectionStats -> ACommand Agent
   OK :: ACommand Agent
   ERR :: AgentErrorType -> ACommand Agent
   SUSPENDED :: ACommand Agent
@@ -235,6 +282,137 @@ deriving instance Eq (ACommand p)
 
 deriving instance Show (ACommand p)
 
+data ACmdTag = forall p. APartyI p => ACmdTag (SAParty p) (ACommandTag p)
+
+data ACommandTag (p :: AParty) where
+  NEW_ :: ACommandTag Client
+  INV_ :: ACommandTag Agent
+  JOIN_ :: ACommandTag Client
+  CONF_ :: ACommandTag Agent
+  LET_ :: ACommandTag Client
+  REQ_ :: ACommandTag Agent
+  ACPT_ :: ACommandTag Client
+  RJCT_ :: ACommandTag Client
+  INFO_ :: ACommandTag Agent
+  CON_ :: ACommandTag Agent
+  SUB_ :: ACommandTag Client
+  END_ :: ACommandTag Agent
+  CONNECT_ :: ACommandTag Agent
+  DISCONNECT_ :: ACommandTag Agent
+  DOWN_ :: ACommandTag Agent
+  UP_ :: ACommandTag Agent
+  SWITCH_ :: ACommandTag Agent
+  SEND_ :: ACommandTag Client
+  MID_ :: ACommandTag Agent
+  SENT_ :: ACommandTag Agent
+  MERR_ :: ACommandTag Agent
+  MSG_ :: ACommandTag Agent
+  ACK_ :: ACommandTag Client
+  SWCH_ :: ACommandTag Client
+  OFF_ :: ACommandTag Client
+  DEL_ :: ACommandTag Client
+  CHK_ :: ACommandTag Client
+  STAT_ :: ACommandTag Agent
+  OK_ :: ACommandTag Agent
+  ERR_ :: ACommandTag Agent
+  SUSPENDED_ :: ACommandTag Agent
+
+deriving instance Eq (ACommandTag p)
+
+deriving instance Show (ACommandTag p)
+
+aCommandTag :: ACommand p -> ACommandTag p
+aCommandTag = \case
+  NEW {} -> NEW_
+  INV _ -> INV_
+  JOIN {} -> JOIN_
+  CONF {} -> CONF_
+  LET {} -> LET_
+  REQ {} -> REQ_
+  ACPT {} -> ACPT_
+  RJCT _ -> RJCT_
+  INFO _ -> INFO_
+  CON -> CON_
+  SUB -> SUB_
+  END -> END_
+  CONNECT {} -> CONNECT_
+  DISCONNECT {} -> DISCONNECT_
+  DOWN {} -> DOWN_
+  UP {} -> UP_
+  SWITCH {} -> SWITCH_
+  SEND {} -> SEND_
+  MID _ -> MID_
+  SENT _ -> SENT_
+  MERR {} -> MERR_
+  MSG {} -> MSG_
+  ACK _ -> ACK_
+  SWCH -> SWCH_
+  OFF -> OFF_
+  DEL -> DEL_
+  CHK -> CHK_
+  STAT _ -> STAT_
+  OK -> OK_
+  ERR _ -> ERR_
+  SUSPENDED -> SUSPENDED_
+
+data QueueDirection = QDRcv | QDSnd
+  deriving (Eq, Show)
+
+instance StrEncoding QueueDirection where
+  strEncode = \case
+    QDRcv -> "rcv"
+    QDSnd -> "snd"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "rcv" -> pure QDRcv
+      "snd" -> pure QDSnd
+      _ -> fail "bad QueueDirection"
+
+instance ToJSON QueueDirection where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance FromJSON QueueDirection where
+  parseJSON = strParseJSON "QueueDirection"
+
+data SwitchPhase = SPStarted | SPConfirmed | SPCompleted
+  deriving (Eq, Show)
+
+instance StrEncoding SwitchPhase where
+  strEncode = \case
+    SPStarted -> "started"
+    SPConfirmed -> "confirmed"
+    SPCompleted -> "completed"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "started" -> pure SPStarted
+      "confirmed" -> pure SPConfirmed
+      "completed" -> pure SPCompleted
+      _ -> fail "bad SwitchPhase"
+
+instance ToJSON SwitchPhase where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance FromJSON SwitchPhase where
+  parseJSON = strParseJSON "SwitchPhase"
+
+data ConnectionStats = ConnectionStats
+  { rcvServers :: [SMPServer],
+    sndServers :: [SMPServer]
+  }
+  deriving (Eq, Show, Generic)
+
+instance StrEncoding ConnectionStats where
+  strEncode ConnectionStats {rcvServers, sndServers} =
+    "rcv=" <> strEncodeList rcvServers <> " snd=" <> strEncodeList sndServers
+  strP = do
+    rcvServers <- "rcv=" *> strListP
+    sndServers <- " snd=" *> strListP
+    pure ConnectionStats {rcvServers, sndServers}
+
+instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
+
 data NotificationsMode = NMPeriodic | NMInstant
   deriving (Eq, Show)
 
@@ -325,7 +503,9 @@ data SMPConfirmation = SMPConfirmation
     -- | sender's information to be associated with the connection, e.g. sender's profile information
     connInfo :: ConnInfo,
     -- | optional reply queues included in confirmation (added in agent protocol v2)
-    smpReplyQueues :: [SMPQueueInfo]
+    smpReplyQueues :: [SMPQueueInfo],
+    -- | SMP client version
+    smpClientVersion :: Version
   }
   deriving (Show)
 
@@ -391,7 +571,17 @@ instance Encoding AgentMessage where
       'M' -> AgentMessage <$> smpP <*> smpP
       _ -> fail "bad AgentMessage"
 
-data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
+data AgentMessageType
+  = AM_CONN_INFO
+  | AM_CONN_INFO_REPLY
+  | AM_HELLO_
+  | AM_REPLY_
+  | AM_A_MSG_
+  | AM_QCONT_
+  | AM_QADD_
+  | AM_QKEY_
+  | AM_QUSE_
+  | AM_QTEST_
   deriving (Eq, Show)
 
 instance Encoding AgentMessageType where
@@ -401,6 +591,11 @@ instance Encoding AgentMessageType where
     AM_HELLO_ -> "H"
     AM_REPLY_ -> "R"
     AM_A_MSG_ -> "M"
+    AM_QCONT_ -> "QC"
+    AM_QADD_ -> "QA"
+    AM_QKEY_ -> "QK"
+    AM_QUSE_ -> "QU"
+    AM_QTEST_ -> "QT"
   smpP =
     A.anyChar >>= \case
       'C' -> pure AM_CONN_INFO
@@ -408,6 +603,14 @@ instance Encoding AgentMessageType where
       'H' -> pure AM_HELLO_
       'R' -> pure AM_REPLY_
       'M' -> pure AM_A_MSG_
+      'Q' ->
+        A.anyChar >>= \case
+          'C' -> pure AM_QCONT_
+          'A' -> pure AM_QADD_
+          'K' -> pure AM_QKEY_
+          'U' -> pure AM_QUSE_
+          'T' -> pure AM_QTEST_
+          _ -> fail "bad AgentMessageType"
       _ -> fail "bad AgentMessageType"
 
 agentMessageType :: AgentMessage -> AgentMessageType
@@ -423,6 +626,11 @@ agentMessageType = \case
     -- REPLY is only used in v1
     REPLY _ -> AM_REPLY_
     A_MSG _ -> AM_A_MSG_
+    QCONT _ -> AM_QCONT_
+    QADD _ -> AM_QADD_
+    QKEY _ -> AM_QKEY_
+    QUSE _ -> AM_QUSE_
+    QTEST _ -> AM_QTEST_
 
 data APrivHeader = APrivHeader
   { -- | sequential ID assigned by the sending agent
@@ -437,7 +645,15 @@ instance Encoding APrivHeader where
     smpEncode (sndMsgId, prevMsgHash)
   smpP = APrivHeader <$> smpP <*> smpP
 
-data AMsgType = HELLO_ | REPLY_ | A_MSG_
+data AMsgType
+  = HELLO_
+  | REPLY_
+  | A_MSG_
+  | QCONT_
+  | QADD_
+  | QKEY_
+  | QUSE_
+  | QTEST_
   deriving (Eq)
 
 instance Encoding AMsgType where
@@ -445,11 +661,24 @@ instance Encoding AMsgType where
     HELLO_ -> "H"
     REPLY_ -> "R"
     A_MSG_ -> "M"
+    QCONT_ -> "QC"
+    QADD_ -> "QA"
+    QKEY_ -> "QK"
+    QUSE_ -> "QU"
+    QTEST_ -> "QT"
   smpP =
-    smpP >>= \case
+    A.anyChar >>= \case
       'H' -> pure HELLO_
       'R' -> pure REPLY_
       'M' -> pure A_MSG_
+      'Q' ->
+        A.anyChar >>= \case
+          'C' -> pure QCONT_
+          'A' -> pure QADD_
+          'K' -> pure QKEY_
+          'U' -> pure QUSE_
+          'T' -> pure QTEST_
+          _ -> fail "bad AMsgType"
       _ -> fail "bad AMsgType"
 
 -- | Messages sent between SMP agents once SMP queue is secured.
@@ -462,19 +691,41 @@ data AMessage
     REPLY (L.NonEmpty SMPQueueInfo)
   | -- | agent envelope for the client message
     A_MSG MsgBody
+  | -- | the message instructing the client to continue sending messages (after ERR QUOTA)
+    QCONT SndQAddr
+  | -- add queue to connection (sent by recipient), with optional address of the replaced queue
+    QADD (L.NonEmpty (SMPQueueUri, Maybe SndQAddr))
+  | -- key to secure the added queues and agree e2e encryption key (sent by sender)
+    QKEY (L.NonEmpty (SMPQueueInfo, SndPublicVerifyKey))
+  | -- inform that the queues are ready to use (sent by recipient)
+    QUSE (L.NonEmpty (SndQAddr, Bool))
+  | -- sent by the sender to test new queues and to complete switching
+    QTEST (L.NonEmpty SndQAddr)
   deriving (Show)
 
+type SndQAddr = (SMPServer, SMP.SenderId)
+
 instance Encoding AMessage where
   smpEncode = \case
     HELLO -> smpEncode HELLO_
     REPLY smpQueues -> smpEncode (REPLY_, smpQueues)
     A_MSG body -> smpEncode (A_MSG_, Tail body)
+    QCONT addr -> smpEncode (QCONT_, addr)
+    QADD qs -> smpEncode (QADD_, qs)
+    QKEY qs -> smpEncode (QKEY_, qs)
+    QUSE qs -> smpEncode (QUSE_, qs)
+    QTEST qs -> smpEncode (QTEST_, qs)
   smpP =
     smpP
       >>= \case
         HELLO_ -> pure HELLO
         REPLY_ -> REPLY <$> smpP
         A_MSG_ -> A_MSG . unTail <$> smpP
+        QCONT_ -> QCONT <$> smpP
+        QADD_ -> QADD <$> smpP
+        QKEY_ -> QKEY <$> smpP
+        QUSE_ -> QUSE <$> smpP
+        QTEST_ -> QTEST <$> smpP
 
 instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
   strEncode = \case
@@ -482,13 +733,14 @@ instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) whe
     CRContactUri crData -> crEncode "contact" crData Nothing
     where
       crEncode :: ByteString -> ConnReqUriData -> Maybe (E2ERatchetParamsUri 'C.X448) -> ByteString
-      crEncode crMode ConnReqUriData {crScheme, crAgentVRange, crSmpQueues} e2eParams =
+      crEncode crMode ConnReqUriData {crScheme, crAgentVRange, crSmpQueues, crClientData} e2eParams =
         strEncode crScheme <> "/" <> crMode <> "#/?" <> queryStr
         where
           queryStr =
             strEncode . QSP QEscape $
               [("v", strEncode crAgentVRange), ("smp", strEncode crSmpQueues)]
                 <> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams
+                <> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData
   strP = do
     ACR m cr <- strP
     case testEquality m $ sConnectionMode @m of
@@ -503,7 +755,8 @@ instance StrEncoding AConnectionRequestUri where
     query <- strP
     crAgentVRange <- queryParam "v" query
     crSmpQueues <- queryParam "smp" query
-    let crData = ConnReqUriData {crScheme, crAgentVRange, crSmpQueues}
+    let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query
+    let crData = ConnReqUriData {crScheme, crAgentVRange, crSmpQueues, crClientData}
     case crMode of
       CMInvitation -> do
         crE2eParams <- queryParam "e2e" query
@@ -553,20 +806,41 @@ type ConfirmationId = ByteString
 
 type InvitationId = ByteString
 
-data SMPQueueInfo = SMPQueueInfo
-  { clientVersion :: Version,
-    smpServer :: SMPServer,
-    senderId :: SMP.SenderId,
-    dhPublicKey :: C.PublicKeyX25519
-  }
+extraSMPServerHosts :: Map TransportHost TransportHost
+extraSMPServerHosts =
+  M.fromList
+    [ ("smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
+      ("smp5.simplex.im", "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"),
+      ("smp6.simplex.im", "bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"),
+      ("smp8.simplex.im", "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion"),
+      ("smp9.simplex.im", "jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion"),
+      ("smp10.simplex.im", "rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion")
+    ]
+
+updateSMPServerHosts :: SMPServer -> SMPServer
+updateSMPServerHosts srv@ProtocolServer {host} = case host of
+  h :| [] -> case M.lookup h extraSMPServerHosts of
+    Just h' -> srv {host = [h, h']}
+    _ -> srv
+  _ -> srv
+
+class SMPQueue q where
+  qServer :: q -> SMPServer
+  qAddress :: q -> (SMPServer, SMP.QueueId)
+  sameQueue :: (SMPServer, SMP.QueueId) -> q -> Bool
+
+data SMPQueueInfo = SMPQueueInfo {clientVersion :: Version, queueAddress :: SMPQueueAddress}
   deriving (Eq, Show)
 
 instance Encoding SMPQueueInfo where
-  smpEncode SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey} =
-    smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
+  smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey})
+    | clientVersion > 1 = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
+    | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
   smpP = do
-    (clientVersion, smpServer, senderId, dhPublicKey) <- smpP
-    pure SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey}
+    clientVersion <- smpP
+    smpServer <- if clientVersion > 1 then smpP else updateSMPServerHosts <$> legacyServerP
+    (senderId, dhPublicKey) <- smpP
+    pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}
 
 -- This instance seems contrived and there was a temptation to split a common part of both types.
 -- But this is created to allow backward and forward compatibility where SMPQueueUri
@@ -575,43 +849,86 @@ instance Encoding SMPQueueInfo where
 instance VersionI SMPQueueInfo where
   type VersionRangeT SMPQueueInfo = SMPQueueUri
   version = clientVersion
-  toVersionRangeT SMPQueueInfo {smpServer, senderId, dhPublicKey} vr =
-    SMPQueueUri {clientVRange = vr, smpServer, senderId, dhPublicKey}
+  toVersionRangeT (SMPQueueInfo _v addr) vr = SMPQueueUri vr addr
 
 instance VersionRangeI SMPQueueUri where
   type VersionT SMPQueueUri = SMPQueueInfo
   versionRange = clientVRange
-  toVersionT SMPQueueUri {smpServer, senderId, dhPublicKey} v =
-    SMPQueueInfo {clientVersion = v, smpServer, senderId, dhPublicKey}
+  toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr
 
 -- | SMP queue information sent out-of-band.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
-data SMPQueueUri = SMPQueueUri
+data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRange, queueAddress :: SMPQueueAddress}
+  deriving (Eq, Show)
+
+data SMPQueueAddress = SMPQueueAddress
   { smpServer :: SMPServer,
     senderId :: SMP.SenderId,
-    clientVRange :: VersionRange,
     dhPublicKey :: C.PublicKeyX25519
   }
   deriving (Eq, Show)
 
+instance SMPQueue SMPQueueUri where
+  qServer SMPQueueUri {queueAddress} = qServer queueAddress
+  {-# INLINE qServer #-}
+  qAddress SMPQueueUri {queueAddress} = qAddress queueAddress
+  {-# INLINE qAddress #-}
+  sameQueue addr q = sameQAddress addr (qAddress q)
+  {-# INLINE sameQueue #-}
+
+instance SMPQueue SMPQueueInfo where
+  qServer SMPQueueInfo {queueAddress} = qServer queueAddress
+  {-# INLINE qServer #-}
+  qAddress SMPQueueInfo {queueAddress} = qAddress queueAddress
+  {-# INLINE qAddress #-}
+  sameQueue addr q = sameQAddress addr (qAddress q)
+  {-# INLINE sameQueue #-}
+
+instance SMPQueue SMPQueueAddress where
+  qServer SMPQueueAddress {smpServer} = smpServer
+  {-# INLINE qServer #-}
+  qAddress SMPQueueAddress {smpServer, senderId} = (smpServer, senderId)
+  {-# INLINE qAddress #-}
+  sameQueue addr q = sameQAddress addr (qAddress q)
+  {-# INLINE sameQueue #-}
+
+sameQAddress :: (SMPServer, SMP.QueueId) -> (SMPServer, SMP.QueueId) -> Bool
+sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId'
+{-# INLINE sameQAddress #-}
+
 instance StrEncoding SMPQueueUri where
-  -- v1 uses short SMP queue URI format
-  strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =
-    strEncode srv <> "/" <> strEncode qId <> "#" <> strEncode k
-  strP = do
-    smpServer <- strP <* A.char '/'
-    senderId <- strP <* optional (A.char '/') <* A.char '#'
-    (vr, dhPublicKey) <- unversioned <|> versioned
-    pure SMPQueueUri {smpServer, senderId, clientVRange = vr, dhPublicKey}
+  strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey})
+    | minVersion vr > 1 = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
+    | otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
     where
-      unversioned = (SMP.smpClientVRange,) <$> strP <* A.endOfInput
+      query = strEncode . QSP QEscape
+      queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)]
+      srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)]
+      hs = L.tail $ host srv
+  strP = do
+    srv@ProtocolServer {host = h :| host} <- strP <* A.char '/'
+    senderId <- strP <* optional (A.char '/') <* A.char '#'
+    (vr, hs, dhPublicKey) <- unversioned <|> versioned
+    let srv' = srv {host = h :| host <> hs}
+        smpServer = if maxVersion vr == 1 then updateSMPServerHosts srv' else srv'
+    pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey}
+    where
+      unversioned = (versionToRange 1,[],) <$> strP <* A.endOfInput
       versioned = do
         dhKey_ <- optional strP
         query <- optional (A.char '/') *> A.char '?' *> strP
         vr <- queryParam "v" query
         dhKey <- maybe (queryParam "dh" query) pure dhKey_
-        pure (vr, dhKey)
+        hs_ <- queryParam_ "srv" query
+        pure (vr, maybe [] thList_ hs_, dhKey)
+
+instance Encoding SMPQueueUri where
+  smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}) =
+    smpEncode (clientVRange, smpServer, senderId, dhPublicKey)
+  smpP = do
+    (clientVRange, smpServer, senderId, dhPublicKey) <- smpP
+    pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}
 
 data ConnectionRequestUri (m :: ConnectionMode) where
   CRInvitationUri :: ConnReqUriData -> E2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
@@ -635,10 +952,13 @@ deriving instance Show AConnectionRequestUri
 data ConnReqUriData = ConnReqUriData
   { crScheme :: ConnReqScheme,
     crAgentVRange :: VersionRange,
-    crSmpQueues :: L.NonEmpty SMPQueueUri
+    crSmpQueues :: L.NonEmpty SMPQueueUri,
+    crClientData :: Maybe CRClientData
   }
   deriving (Eq, Show)
 
+type CRClientData = Text
+
 data ConnReqScheme = CRSSimplex | CRSAppServer SrvLoc
   deriving (Eq, Show)
 
@@ -742,12 +1062,12 @@ data AgentErrorType
   | -- | NTF protocol errors forwarded to agent clients
     NTF {ntfErr :: ErrorType}
   | -- | SMP server errors
-    BROKER {brokerErr :: BrokerErrorType}
+    BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
   | -- | errors of other agents
     AGENT {agentErr :: SMPAgentError}
   | -- | agent implementation or dependency errors
     INTERNAL {internalErr :: String}
-  deriving (Eq, Generic, Read, Show, Exception)
+  deriving (Eq, Generic, Show, Exception)
 
 instance ToJSON AgentErrorType where
   toJSON = J.genericToJSON $ sumTypeJSON id
@@ -797,6 +1117,8 @@ data BrokerErrorType
     UNEXPECTED
   | -- | network error
     NETWORK
+  | -- | no compatible server host (e.g. onion when public is required, or vice versa)
+    HOST
   | -- | handshake or other transport error
     TRANSPORT {transportErr :: TransportError}
   | -- | command response timeout
@@ -808,7 +1130,6 @@ instance ToJSON BrokerErrorType where
   toEncoding = J.genericToEncoding $ sumTypeJSON id
 
 -- | Errors of another SMP agent.
--- TODO encode/decode without A prefix
 data SMPAgentError
   = -- | client or agent message that failed to parse
     A_MESSAGE
@@ -820,6 +1141,8 @@ data SMPAgentError
     A_ENCRYPTION
   | -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
     A_DUPLICATE
+  | -- | error in the message to add/delete/etc queue in connection
+    A_QUEUE {queueErr :: String}
   deriving (Eq, Generic, Read, Show, Exception)
 
 instance ToJSON SMPAgentError where
@@ -832,21 +1155,27 @@ instance StrEncoding AgentErrorType where
       <|> "CONN " *> (CONN <$> parseRead1)
       <|> "SMP " *> (SMP <$> strP)
       <|> "NTF " *> (NTF <$> strP)
-      <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> strP)
-      <|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
-      <|> "BROKER " *> (BROKER <$> parseRead1)
+      <|> "BROKER " *> (BROKER <$> srvP <* " RESPONSE " <*> (RESPONSE <$> strP))
+      <|> "BROKER " *> (BROKER <$> srvP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
+      <|> "BROKER " *> (BROKER <$> srvP <* A.space <*> parseRead1)
+      <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
       <|> "AGENT " *> (AGENT <$> parseRead1)
       <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
+    where
+      srvP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
   strEncode = \case
     CMD e -> "CMD " <> bshow e
     CONN e -> "CONN " <> bshow e
     SMP e -> "SMP " <> strEncode e
     NTF e -> "NTF " <> strEncode e
-    BROKER (RESPONSE e) -> "BROKER RESPONSE " <> strEncode e
-    BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
-    BROKER e -> "BROKER " <> bshow e
+    BROKER srv (RESPONSE e) -> "BROKER " <> addr srv <> " RESPONSE " <> strEncode e
+    BROKER srv (TRANSPORT e) -> "BROKER " <> addr srv <> " TRANSPORT " <> serializeTransportError e
+    BROKER srv e -> "BROKER " <> addr srv <> " " <> bshow e
+    AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
     AGENT e -> "AGENT " <> bshow e
     INTERNAL e -> "INTERNAL " <> bshow e
+    where
+      addr = encodeUtf8 . T.pack
 
 instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
 
@@ -858,51 +1187,135 @@ instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
 
 instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
 
+-- | SMP agent command and response parser for commands passed via network (only parses binary length)
+networkCommandP :: Parser ACmd
+networkCommandP = commandP A.takeByteString
+
+-- | SMP agent command and response parser for commands stored in db (fully parses binary bodies)
+dbCommandP :: Parser ACmd
+dbCommandP = commandP $ A.take =<< (A.decimal <* "\n")
+
+instance StrEncoding ACmdTag where
+  strEncode (ACmdTag _ cmd) = strEncode cmd
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "NEW" -> pure $ ACmdTag SClient NEW_
+      "INV" -> pure $ ACmdTag SAgent INV_
+      "JOIN" -> pure $ ACmdTag SClient JOIN_
+      "CONF" -> pure $ ACmdTag SAgent CONF_
+      "LET" -> pure $ ACmdTag SClient LET_
+      "REQ" -> pure $ ACmdTag SAgent REQ_
+      "ACPT" -> pure $ ACmdTag SClient ACPT_
+      "RJCT" -> pure $ ACmdTag SClient RJCT_
+      "INFO" -> pure $ ACmdTag SAgent INFO_
+      "CON" -> pure $ ACmdTag SAgent CON_
+      "SUB" -> pure $ ACmdTag SClient SUB_
+      "END" -> pure $ ACmdTag SAgent END_
+      "CONNECT" -> pure $ ACmdTag SAgent CONNECT_
+      "DISCONNECT" -> pure $ ACmdTag SAgent DISCONNECT_
+      "DOWN" -> pure $ ACmdTag SAgent DOWN_
+      "UP" -> pure $ ACmdTag SAgent UP_
+      "SWITCH" -> pure $ ACmdTag SAgent SWITCH_
+      "SEND" -> pure $ ACmdTag SClient SEND_
+      "MID" -> pure $ ACmdTag SAgent MID_
+      "SENT" -> pure $ ACmdTag SAgent SENT_
+      "MERR" -> pure $ ACmdTag SAgent MERR_
+      "MSG" -> pure $ ACmdTag SAgent MSG_
+      "ACK" -> pure $ ACmdTag SClient ACK_
+      "SWCH" -> pure $ ACmdTag SClient SWCH_
+      "OFF" -> pure $ ACmdTag SClient OFF_
+      "DEL" -> pure $ ACmdTag SClient DEL_
+      "CHK" -> pure $ ACmdTag SClient CHK_
+      "STAT" -> pure $ ACmdTag SAgent STAT_
+      "OK" -> pure $ ACmdTag SAgent OK_
+      "ERR" -> pure $ ACmdTag SAgent ERR_
+      "SUSPENDED" -> pure $ ACmdTag SAgent SUSPENDED_
+      _ -> fail "bad ACmdTag"
+
+instance APartyI p => StrEncoding (ACommandTag p) where
+  strEncode = \case
+    NEW_ -> "NEW"
+    INV_ -> "INV"
+    JOIN_ -> "JOIN"
+    CONF_ -> "CONF"
+    LET_ -> "LET"
+    REQ_ -> "REQ"
+    ACPT_ -> "ACPT"
+    RJCT_ -> "RJCT"
+    INFO_ -> "INFO"
+    CON_ -> "CON"
+    SUB_ -> "SUB"
+    END_ -> "END"
+    CONNECT_ -> "CONNECT"
+    DISCONNECT_ -> "DISCONNECT"
+    DOWN_ -> "DOWN"
+    UP_ -> "UP"
+    SWITCH_ -> "SWITCH"
+    SEND_ -> "SEND"
+    MID_ -> "MID"
+    SENT_ -> "SENT"
+    MERR_ -> "MERR"
+    MSG_ -> "MSG"
+    ACK_ -> "ACK"
+    SWCH_ -> "SWCH"
+    OFF_ -> "OFF"
+    DEL_ -> "DEL"
+    CHK_ -> "CHK"
+    STAT_ -> "STAT"
+    OK_ -> "OK"
+    ERR_ -> "ERR"
+    SUSPENDED_ -> "SUSPENDED"
+  strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP
+
+checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p)
+checkParty x = case testEquality (sAParty @p) (sAParty @p') of
+  Just Refl -> Right x
+  Nothing -> Left "bad party"
+
 -- | SMP agent command and response parser
-commandP :: Parser ACmd
-commandP =
-  "NEW " *> newCmd
-    <|> "INV " *> invResp
-    <|> "JOIN " *> joinCmd
-    <|> "CONF " *> confMsg
-    <|> "LET " *> letCmd
-    <|> "REQ " *> reqMsg
-    <|> "ACPT " *> acptCmd
-    <|> "RJCT " *> rjctCmd
-    <|> "INFO " *> infoCmd
-    <|> "SUB" $> ACmd SClient SUB
-    <|> "END" $> ACmd SAgent END
-    <|> "DOWN " *> downsResp
-    <|> "UP " *> upsResp
-    <|> "SEND " *> sendCmd
-    <|> "MID " *> msgIdResp
-    <|> "SENT " *> sentResp
-    <|> "MERR " *> msgErrResp
-    <|> "MSG " *> message
-    <|> "ACK " *> ackCmd
-    <|> "OFF" $> ACmd SClient OFF
-    <|> "DEL" $> ACmd SClient DEL
-    <|> "ERR " *> agentError
-    <|> "CON" $> ACmd SAgent CON
-    <|> "OK" $> ACmd SAgent OK
+commandP :: Parser ByteString -> Parser ACmd
+commandP binaryP =
+  strP
+    >>= \case
+      ACmdTag SClient cmd ->
+        ACmd SClient <$> case cmd of
+          NEW_ -> s (NEW <$> strP_ <*> strP)
+          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> binaryP)
+          LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
+          ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> binaryP)
+          RJCT_ -> s (RJCT <$> A.takeByteString)
+          SUB_ -> pure SUB
+          SEND_ -> s (SEND <$> smpP <* A.space <*> binaryP)
+          ACK_ -> s (ACK <$> A.decimal)
+          SWCH_ -> pure SWCH
+          OFF_ -> pure OFF
+          DEL_ -> pure DEL
+          CHK_ -> pure CHK
+      ACmdTag SAgent cmd ->
+        ACmd SAgent <$> case cmd of
+          INV_ -> s (INV <$> strP)
+          CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP)
+          REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP)
+          INFO_ -> s (INFO <$> binaryP)
+          CON_ -> pure CON
+          END_ -> pure END
+          CONNECT_ -> s (CONNECT <$> strP_ <*> strP)
+          DISCONNECT_ -> s (DISCONNECT <$> strP_ <*> strP)
+          DOWN_ -> s (DOWN <$> strP_ <*> connections)
+          UP_ -> s (UP <$> strP_ <*> connections)
+          SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
+          MID_ -> s (MID <$> A.decimal)
+          SENT_ -> s (SENT <$> A.decimal)
+          MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
+          MSG_ -> s (MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> binaryP)
+          STAT_ -> s (STAT <$> strP)
+          OK_ -> pure OK
+          ERR_ -> s (ERR <$> strP)
+          SUSPENDED_ -> pure SUSPENDED
   where
-    newCmd = ACmd SClient . NEW <$> strP
-    invResp = ACmd SAgent . INV <$> strP
-    joinCmd = ACmd SClient .: JOIN <$> strP_ <*> A.takeByteString
-    confMsg = ACmd SAgent .: CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    reqMsg = ACmd SAgent .: REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    rjctCmd = ACmd SClient . RJCT <$> A.takeByteString
-    infoCmd = ACmd SAgent . INFO <$> A.takeByteString
-    downsResp = ACmd SAgent .: DOWN <$> strP_ <*> connections
-    upsResp = ACmd SAgent .: UP <$> strP_ <*> connections
-    sendCmd = ACmd SClient .: SEND <$> smpP <* A.space <*> A.takeByteString
-    msgIdResp = ACmd SAgent . MID <$> A.decimal
-    sentResp = ACmd SAgent . SENT <$> A.decimal
-    msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
-    message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> A.takeByteString
-    ackCmd = ACmd SClient . ACK <$> A.decimal
+    s :: Parser a -> Parser a
+    s p = A.space *> p
+    connections :: Parser [ConnId]
     connections = strP `A.sepBy'` A.char ','
     msgMetaP = do
       integrity <- strP
@@ -911,40 +1324,47 @@ commandP =
       sndMsgId <- " S=" *> A.decimal
       pure MsgMeta {integrity, recipient, broker, sndMsgId}
     partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P
-    agentError = ACmd SAgent . ERR <$> strP
 
 parseCommand :: ByteString -> Either AgentErrorType ACmd
-parseCommand = parse commandP $ CMD SYNTAX
+parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
 
 -- | Serialize SMP agent command.
 serializeCommand :: ACommand p -> ByteString
 serializeCommand = \case
-  NEW cMode -> "NEW " <> strEncode cMode
-  INV cReq -> "INV " <> strEncode cReq
-  JOIN cReq cInfo -> B.unwords ["JOIN", strEncode cReq, serializeBinary cInfo]
-  CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]
-  LET confId cInfo -> B.unwords ["LET", confId, serializeBinary cInfo]
-  REQ invId cInfo -> B.unwords ["REQ", invId, serializeBinary cInfo]
-  ACPT invId cInfo -> B.unwords ["ACPT", invId, serializeBinary cInfo]
-  RJCT invId -> "RJCT " <> invId
-  INFO cInfo -> "INFO " <> serializeBinary cInfo
-  SUB -> "SUB"
-  END -> "END"
-  DOWN srv conns -> B.unwords ["DOWN", strEncode srv, connections conns]
-  UP srv conns -> B.unwords ["UP", strEncode srv, connections conns]
-  SEND msgFlags msgBody -> "SEND " <> smpEncode msgFlags <> " " <> serializeBinary msgBody
-  MID mId -> "MID " <> bshow mId
-  SENT mId -> "SENT " <> bshow mId
-  MERR mId e -> B.unwords ["MERR", bshow mId, strEncode e]
-  MSG msgMeta msgFlags msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, smpEncode msgFlags, serializeBinary msgBody]
-  ACK mId -> "ACK " <> bshow mId
-  OFF -> "OFF"
-  DEL -> "DEL"
-  CON -> "CON"
-  ERR e -> "ERR " <> strEncode e
-  OK -> "OK"
-  SUSPENDED -> "SUSPENDED"
+  NEW ntfs cMode -> s (NEW_, ntfs, cMode)
+  INV cReq -> s (INV_, cReq)
+  JOIN ntfs cReq cInfo -> s (JOIN_, ntfs, cReq, Str $ serializeBinary cInfo)
+  CONF confId srvs cInfo -> B.unwords [s CONF_, confId, strEncodeList srvs, serializeBinary cInfo]
+  LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo]
+  REQ invId srvs cInfo -> B.unwords [s REQ_, invId, s srvs, serializeBinary cInfo]
+  ACPT invId cInfo -> B.unwords [s ACPT_, invId, serializeBinary cInfo]
+  RJCT invId -> B.unwords [s RJCT_, invId]
+  INFO cInfo -> B.unwords [s INFO_, serializeBinary cInfo]
+  SUB -> s SUB_
+  END -> s END_
+  CONNECT p h -> s (CONNECT_, p, h)
+  DISCONNECT p h -> s (DISCONNECT_, p, h)
+  DOWN srv conns -> B.unwords [s DOWN_, s srv, connections conns]
+  UP srv conns -> B.unwords [s UP_, s srv, connections conns]
+  SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
+  SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
+  MID mId -> s (MID_, Str $ bshow mId)
+  SENT mId -> s (SENT_, Str $ bshow mId)
+  MERR mId e -> s (MERR_, Str $ bshow mId, e)
+  MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, serializeMsgMeta msgMeta, smpEncode msgFlags, serializeBinary msgBody]
+  ACK mId -> s (ACK_, Str $ bshow mId)
+  SWCH -> s SWCH_
+  OFF -> s OFF_
+  DEL -> s DEL_
+  CHK -> s CHK_
+  STAT srvs -> s (STAT_, srvs)
+  CON -> s CON_
+  ERR e -> s (ERR_, e)
+  OK -> s OK_
+  SUSPENDED -> s SUSPENDED_
   where
+    s :: StrEncoding a => a -> ByteString
+    s = strEncode
     showTs :: UTCTime -> ByteString
     showTs = B.pack . formatISO8601Millis
     connections :: [ConnId] -> ByteString
@@ -995,11 +1415,13 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     tConnId :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p)
     tConnId (_, connId, _) cmd = case cmd of
       -- NEW, JOIN and ACPT have optional connId
-      NEW _ -> Right cmd
+      NEW {} -> Right cmd
       JOIN {} -> Right cmd
       ACPT {} -> Right cmd
       -- ERROR response does not always have connId
       ERR _ -> Right cmd
+      CONNECT {} -> Right cmd
+      DISCONNECT {} -> Right cmd
       DOWN {} -> Right cmd
       UP {} -> Right cmd
       -- other responses must have connId
@@ -1011,10 +1433,10 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     cmdWithMsgBody = \case
       SEND msgFlags body -> SEND msgFlags <$$> getBody body
       MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
-      JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
-      CONF confId cInfo -> CONF confId <$$> getBody cInfo
+      JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo
+      CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
       LET confId cInfo -> LET confId <$$> getBody cInfo
-      REQ invId cInfo -> REQ invId <$$> getBody cInfo
+      REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
       ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
       INFO cInfo -> INFO <$$> getBody cInfo
       cmd -> pure $ Right cmd

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,
@@ -31,13 +40,15 @@ import Simplex.Messaging.Protocol
     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,
+  { connId :: ConnId,
+    server :: SMPServer,
     -- | recipient queue ID
     rcvId :: SMP.RecipientId,
     -- | key used by the recipient to sign transmissions
@@ -49,9 +60,17 @@ 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
   }
@@ -70,7 +89,8 @@ data ClientNtfCreds = ClientNtfCreds
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
 data SndQueue = SndQueue
-  { server :: SMPServer,
+  { connId :: ConnId,
+    server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
     -- | key pair used by the sender to sign transmissions
@@ -81,14 +101,59 @@ 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 #-}
+
 -- * 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 +166,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
@@ -147,10 +223,124 @@ deriving instance Show SomeConn
 data ConnData = ConnData
   { connId :: ConnId,
     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 AgentCmdType = ACClient | ACInternal
+
+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 +455,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.
@@ -288,6 +484,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 +494,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.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -22,18 +23,34 @@ module Simplex.Messaging.Agent.Store.SQLite
   ( SQLiteStore (..),
     createSQLiteStore,
     connectSQLiteStore,
+    closeSQLiteStore,
+    sqlString,
+    execSQL,
 
     -- * Queues and connections
+    createNewConn,
+    updateNewConnRcv,
+    updateNewConnSnd,
     createRcvConn,
     createSndConn,
     getConn,
+    getAnyConn,
+    getConnData,
+    setConnDeleted,
     getRcvConn,
     deleteConn,
     upgradeRcvConnToDuplex,
     upgradeSndConnToDuplex,
+    addConnRcvQueue,
+    addConnSndQueue,
     setRcvQueueStatus,
     setRcvQueueConfirmedE2E,
     setSndQueueStatus,
+    setRcvQueuePrimary,
+    setSndQueuePrimary,
+    deleteConnRcvQueue,
+    deleteConnSndQueue,
+    getPrimaryRcvQueue,
     getRcvQueue,
     setRcvQueueNtfCreds,
     -- Confirmations
@@ -46,17 +63,21 @@ module Simplex.Messaging.Agent.Store.SQLite
     createInvitation,
     getInvitation,
     acceptInvitation,
+    unacceptInvitation,
     deleteInvitation,
     -- Messages
     updateRcvIds,
     createRcvMsg,
     updateSndIds,
     createSndMsg,
+    createSndMsgDelivery,
     getPendingMsgData,
     getPendingMsgs,
+    deletePendingMsgs,
     setMsgUserAck,
     getLastMsg,
     deleteMsg,
+    deleteSndMsgDelivery,
     -- Double ratchet persistence
     createRatchetX3dhKeys,
     getRatchetX3dhKeys,
@@ -64,6 +85,11 @@ module Simplex.Messaging.Agent.Store.SQLite
     getRatchet,
     getSkippedMsgKeys,
     updateRatchet,
+    -- Async commands
+    createCommand,
+    getPendingCommands,
+    getPendingCommand,
+    deleteCommand,
     -- Notification device token persistence
     createNtfToken,
     getSavedNtfToken,
@@ -75,8 +101,8 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- Notification subscription persistence
     getNtfSubscription,
     createNtfSubscription,
-    supervisorUpdateNtfSubscription,
-    supervisorUpdateNtfSubAction,
+    supervisorUpdateNtfSub,
+    supervisorUpdateNtfAction,
     updateNtfSubscription,
     setNullNtfSubscriptionAction,
     deleteNtfSubscription,
@@ -84,6 +110,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     getNextNtfSubSMPAction,
     getActiveNtfToken,
     getNtfRcvQueue,
+    setConnectionNtfs,
 
     -- * utilities
     withConnection,
@@ -102,10 +129,16 @@ import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import Data.Char (toLower)
+import Data.Function (on)
 import Data.Functor (($>))
-import Data.List (find, foldl')
+import Data.IORef
+import Data.Int (Int64)
+import Data.List (foldl', groupBy, sortBy)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Ord (Down (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -116,6 +149,7 @@ import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.QQ (sql)
 import Database.SQLite.Simple.ToField (ToField (..))
 import qualified Database.SQLite3 as SQLite3
+import Network.Socket (ServiceName)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration)
@@ -127,15 +161,16 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
-import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, pattern NtfServer)
+import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, SndPublicVerifyKey, pattern NtfServer)
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (takeDirectory)
 import System.IO (hFlush, stdout)
-import UnliftIO.Exception (bracket)
+import UnliftIO.Exception (bracket, onException)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -143,28 +178,19 @@ import UnliftIO.STM
 
 data SQLiteStore = SQLiteStore
   { dbFilePath :: FilePath,
+    dbEncrypted :: TVar Bool,
     dbConnection :: TMVar DB.Connection,
     dbNew :: Bool
   }
 
-createSQLiteStore :: FilePath -> [Migration] -> Bool -> IO SQLiteStore
-createSQLiteStore dbFilePath migrations yesToMigrations = do
+createSQLiteStore :: FilePath -> String -> [Migration] -> Bool -> IO SQLiteStore
+createSQLiteStore dbFilePath dbKey migrations yesToMigrations = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing False dbDir
-  st <- connectSQLiteStore dbFilePath
-  checkThreadsafe st
-  migrateSchema st migrations yesToMigrations
+  st <- connectSQLiteStore dbFilePath dbKey
+  migrateSchema st migrations yesToMigrations `onException` closeSQLiteStore st
   pure st
 
-checkThreadsafe :: SQLiteStore -> IO ()
-checkThreadsafe st = withConnection st $ \db -> do
-  compileOptions <- DB.query_ db "pragma COMPILE_OPTIONS;" :: IO [[Text]]
-  let threadsafeOption = find (T.isPrefixOf "THREADSAFE=") (concat compileOptions)
-  case threadsafeOption of
-    Just "THREADSAFE=0" -> confirmOrExit "SQLite compiled with non-threadsafe code."
-    Nothing -> putStrLn "Warning: SQLite THREADSAFE compile option not found"
-    _ -> return ()
-
 migrateSchema :: SQLiteStore -> [Migration] -> Bool -> IO ()
 migrateSchema st migrations yesToMigrations = withConnection st $ \db -> do
   Migrations.initialize db
@@ -187,24 +213,38 @@ confirmOrExit s = do
   ok <- getLine
   when (map toLower ok /= "y") exitFailure
 
-connectSQLiteStore :: FilePath -> IO SQLiteStore
-connectSQLiteStore dbFilePath = do
+connectSQLiteStore :: FilePath -> String -> IO SQLiteStore
+connectSQLiteStore dbFilePath dbKey = do
   dbNew <- not <$> doesFileExist dbFilePath
-  dbConnection <- newTMVarIO =<< connectDB dbFilePath
-  pure SQLiteStore {dbFilePath, dbConnection, dbNew}
+  dbConnection <- newTMVarIO =<< connectDB dbFilePath dbKey
+  dbEncrypted <- newTVarIO . not $ null dbKey
+  pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection, dbNew}
 
-connectDB :: FilePath -> IO DB.Connection
-connectDB path = do
-  dbConn <- DB.open path
-  SQLite3.exec (DB.connectionHandle dbConn) . fromQuery $
-    [sql|
-      PRAGMA foreign_keys = ON;
-      -- PRAGMA trusted_schema = OFF;
-      PRAGMA secure_delete = ON;
-      PRAGMA auto_vacuum = FULL;
-    |]
-  -- _printPragmas dbConn path
-  pure dbConn
+connectDB :: FilePath -> String -> IO DB.Connection
+connectDB path key = do
+  db <- DB.open path
+  prepare db `onException` DB.close db
+  -- _printPragmas db path
+  pure db
+  where
+    prepare db = do
+      let exec = SQLite3.exec $ DB.connectionHandle db
+      unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";"
+      exec . fromQuery $
+        [sql|
+          PRAGMA foreign_keys = ON;
+          -- PRAGMA trusted_schema = OFF;
+          PRAGMA secure_delete = ON;
+          PRAGMA auto_vacuum = FULL;
+        |]
+
+closeSQLiteStore :: SQLiteStore -> IO ()
+closeSQLiteStore st = atomically (takeTMVar $ dbConnection st) >>= DB.close
+
+sqlString :: String -> Text
+sqlString s = quote <> T.replace quote "''" (T.pack s) <> quote
+  where
+    quote = "'"
 
 -- _printPragmas :: DB.Connection -> FilePath -> IO ()
 -- _printPragmas db path = do
@@ -218,6 +258,19 @@ connectDB path = do
 --   auto_vacuum <- DB.query_ db "PRAGMA auto_vacuum;" :: IO [[Int]]
 --   print $ path <> " auto_vacuum: " <> show auto_vacuum
 
+execSQL :: DB.Connection -> Text -> IO [Text]
+execSQL db query = do
+  rs <- newIORef []
+  SQLite3.execWithCallback (DB.connectionHandle db) query (addSQLResultRow rs)
+  reverse <$> readIORef rs
+
+addSQLResultRow :: IORef [Text] -> SQLite3.ColumnIndex -> [Text] -> [Maybe Text] -> IO ()
+addSQLResultRow rs _count names values = modifyIORef' rs $ \case
+  [] -> [showValues values, T.intercalate "|" names]
+  rs' -> showValues values : rs'
+  where
+    showValues = T.intercalate "|" . map (fromMaybe "")
+
 checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
 checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
 
@@ -253,33 +306,51 @@ createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of
   ConnData {connId = ""} -> createWithRandomId gVar create
   ConnData {connId} -> create connId $> Right connId
 
+createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId)
+createNewConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} cMode =
+  createConn_ gVar cData $ \connId -> do
+    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+
+updateNewConnRcv :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
+updateNewConnRcv db connId rq =
+  getConn db connId $>>= \case
+    (SomeConn _ NewConnection {}) -> updateConn
+    (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+  where
+    updateConn :: IO (Either StoreError Int64)
+    updateConn = Right <$> addConnRcvQueue_ db connId rq
+
+updateNewConnSnd :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
+updateNewConnSnd db connId sq =
+  getConn db connId $>>= \case
+    (SomeConn _ NewConnection {}) -> updateConn
+    (SomeConn _ SndConnection {}) -> updateConn -- to allow retries
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+  where
+    updateConn :: IO (Either StoreError Int64)
+    updateConn = Right <$> addConnSndQueue_ db connId sq
+
 createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId)
-createRcvConn db gVar cData q@RcvQueue {server} cMode =
+createRcvConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode =
   createConn_ gVar cData $ \connId -> do
     upsertServer_ db server
-    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, cMode, connAgentVersion cData, duplexHandshake cData)
-    insertRcvQueue_ db connId q
+    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+    void $ insertRcvQueue_ db connId q
 
 createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId)
-createSndConn db gVar cData q@SndQueue {server} =
+createSndConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} =
   createConn_ gVar cData $ \connId -> do
     upsertServer_ db server
-    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion cData, duplexHandshake cData)
-    insertSndQueue_ db connId q
+    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
+    void $ insertSndQueue_ db connId q
 
-getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError SomeConn)
-getRcvConn db ProtocolServer {host, port} rcvId =
-  DB.queryNamed
-    db
-    [sql|
-      SELECT q.conn_id
-      FROM rcv_queues q
-      WHERE q.host = :host AND q.port = :port AND q.rcv_id = :rcv_id;
-    |]
-    [":host" := host, ":port" := port, ":rcv_id" := rcvId]
-    >>= \case
-      [Only connId] -> getConn db connId
-      _ -> pure $ Left SEConnNotFound
+getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
+getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
+  rq@RcvQueue {connId} <-
+    ExceptT . firstRow toRcvQueue SEConnNotFound $
+      DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?") (host, port, rcvId)
+  (rq,) <$> ExceptT (getConn db connId)
 
 deleteConn :: DB.Connection -> ConnId -> IO ()
 deleteConn db connId =
@@ -288,25 +359,43 @@ deleteConn db connId =
     "DELETE FROM connections WHERE conn_id = :conn_id;"
     [":conn_id" := connId]
 
-upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError ())
-upgradeRcvConnToDuplex db connId sq@SndQueue {server} =
+upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
+upgradeRcvConnToDuplex db connId sq =
   getConn db connId $>>= \case
-    (SomeConn _ RcvConnection {}) -> do
-      upsertServer_ db server
-      insertSndQueue_ db connId sq
-      pure $ Right ()
+    (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq
     (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
 
-upgradeSndConnToDuplex :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError ())
-upgradeSndConnToDuplex db connId rq@RcvQueue {server} =
+upgradeSndConnToDuplex :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
+upgradeSndConnToDuplex db connId rq =
   getConn db connId >>= \case
-    Right (SomeConn _ SndConnection {}) -> do
-      upsertServer_ db server
-      insertRcvQueue_ db connId rq
-      pure $ Right ()
+    Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
     Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
     _ -> pure $ Left SEConnNotFound
 
+addConnRcvQueue :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
+addConnRcvQueue db connId rq =
+  getConn db connId >>= \case
+    Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq
+    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    _ -> pure $ Left SEConnNotFound
+
+addConnRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO Int64
+addConnRcvQueue_ db connId rq@RcvQueue {server} = do
+  upsertServer_ db server
+  insertRcvQueue_ db connId rq
+
+addConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError Int64)
+addConnSndQueue db connId sq =
+  getConn db connId >>= \case
+    Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq
+    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+    _ -> pure $ Left SEConnNotFound
+
+addConnSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO Int64
+addConnSndQueue_ db connId sq@SndQueue {server} = do
+  upsertServer_ db server
+  insertSndQueue_ db connId sq
+
 setRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO ()
 setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} status =
   -- ? return error if queue does not exist?
@@ -319,18 +408,20 @@ setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} stat
     |]
     [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
 
-setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> IO ()
-setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret =
+setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> Version -> IO ()
+setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion =
   DB.executeNamed
     db
     [sql|
       UPDATE rcv_queues
       SET e2e_dh_secret = :e2e_dh_secret,
-          status = :status
+          status = :status,
+          smp_client_version = :smp_client_version
       WHERE host = :host AND port = :port AND rcv_id = :rcv_id
     |]
     [ ":status" := Confirmed,
       ":e2e_dh_secret" := e2eDhSecret,
+      ":smp_client_version" := smpClientVersion,
       ":host" := host,
       ":port" := port,
       ":rcv_id" := rcvId
@@ -348,9 +439,39 @@ setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} stat
     |]
     [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]
 
-getRcvQueue :: DB.Connection -> ConnId -> IO (Either StoreError RcvQueue)
-getRcvQueue db connId =
-  maybe (Left SEConnNotFound) Right <$> getRcvQueueByConnId_ db connId
+setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO ()
+setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do
+  DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId)
+  DB.execute
+    db
+    "UPDATE rcv_queues SET rcv_primary = ?, replace_rcv_queue_id = ? WHERE conn_id = ? AND rcv_queue_id = ?"
+    (True, Nothing :: Maybe Int64, connId, dbQueueId)
+
+setSndQueuePrimary :: DB.Connection -> ConnId -> SndQueue -> IO ()
+setSndQueuePrimary db connId SndQueue {dbQueueId} = do
+  DB.execute db "UPDATE snd_queues SET snd_primary = ? WHERE conn_id = ?" (False, connId)
+  DB.execute
+    db
+    "UPDATE snd_queues SET snd_primary = ?, replace_snd_queue_id = ? WHERE conn_id = ? AND snd_queue_id = ?"
+    (True, Nothing :: Maybe Int64, connId, dbQueueId)
+
+deleteConnRcvQueue :: DB.Connection -> ConnId -> RcvQueue -> IO ()
+deleteConnRcvQueue db connId RcvQueue {dbQueueId} =
+  DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
+
+deleteConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO ()
+deleteConnSndQueue db connId SndQueue {dbQueueId} = do
+  DB.execute db "DELETE FROM snd_queues WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId)
+  DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId)
+
+getPrimaryRcvQueue :: DB.Connection -> ConnId -> IO (Either StoreError RcvQueue)
+getPrimaryRcvQueue db connId =
+  maybe (Left SEConnNotFound) (Right . L.head) <$> getRcvQueuesByConnId_ db connId
+
+getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue)
+getRcvQueue db connId (SMPServer host port _) rcvId =
+  firstRow toRcvQueue SEConnNotFound $
+    DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ?") (connId, host, port, rcvId)
 
 setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO ()
 setRcvQueueNtfCreds db connId clientNtfCreds =
@@ -367,16 +488,28 @@ setRcvQueueNtfCreds db connId clientNtfCreds =
       Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
       Nothing -> (Nothing, Nothing, Nothing, Nothing)
 
+type SMPConfirmationRow = (SndPublicVerifyKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version)
+
+smpConfirmation :: SMPConfirmationRow -> SMPConfirmation
+smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) =
+  SMPConfirmation
+    { senderKey,
+      e2ePubKey,
+      connInfo,
+      smpReplyQueues = fromMaybe [] smpReplyQueues_,
+      smpClientVersion = fromMaybe 1 smpClientVersion_
+    }
+
 createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId)
-createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues}, ratchetState} =
+createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues, smpClientVersion}, ratchetState} =
   createWithRandomId gVar $ \confirmationId ->
     DB.execute
       db
       [sql|
         INSERT INTO conn_confirmations
-        (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, 0);
+        (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0);
       |]
-      (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues)
+      (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues, smpClientVersion)
 
 acceptConfirmation :: DB.Connection -> ConfirmationId -> ConnInfo -> IO (Either StoreError AcceptedConfirmation)
 acceptConfirmation db confirmationId ownConnInfo = do
@@ -395,17 +528,17 @@ acceptConfirmation db confirmationId ownConnInfo = do
     DB.query
       db
       [sql|
-        SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues
+        SELECT conn_id, ratchet_state, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version
         FROM conn_confirmations
         WHERE confirmation_id = ?;
       |]
       (Only confirmationId)
   where
-    confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_) =
+    confirmation ((connId, ratchetState) :. confRow) =
       AcceptedConfirmation
         { confirmationId,
           connId,
-          senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
+          senderConf = smpConfirmation confRow,
           ratchetState,
           ownConnInfo
         }
@@ -416,17 +549,17 @@ getAcceptedConfirmation db connId =
     DB.query
       db
       [sql|
-        SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, own_conn_info
+        SELECT confirmation_id, ratchet_state, own_conn_info, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version
         FROM conn_confirmations
         WHERE conn_id = ? AND accepted = 1;
       |]
       (Only connId)
   where
-    confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_, ownConnInfo) =
+    confirmation ((confirmationId, ratchetState, ownConnInfo) :. confRow) =
       AcceptedConfirmation
         { confirmationId,
           connId,
-          senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
+          senderConf = smpConfirmation confRow,
           ratchetState,
           ownConnInfo
         }
@@ -486,6 +619,10 @@ acceptInvitation db invitationId ownConnInfo =
       ":invitation_id" := invitationId
     ]
 
+unacceptInvitation :: DB.Connection -> InvitationId -> IO ()
+unacceptInvitation db invitationId =
+  DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only invitationId)
+
 deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ())
 deleteInvitation db contactConnId invId =
   getConn db contactConnId $>>= \case
@@ -501,10 +638,10 @@ updateRcvIds db connId = do
   updateLastIdsRcv_ db connId internalId internalRcvId
   pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
 
-createRcvMsg :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
-createRcvMsg db connId rcvMsgData = do
+createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
+createRcvMsg db connId rq rcvMsgData = do
   insertRcvMsgBase_ db connId rcvMsgData
-  insertRcvMsgDetails_ db connId rcvMsgData
+  insertRcvMsgDetails_ db connId rq rcvMsgData
   updateHashRcv_ db connId rcvMsgData
 
 updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
@@ -521,9 +658,13 @@ createSndMsg db connId sndMsgData = do
   insertSndMsgDetails_ db connId sndMsgData
   updateHashSnd_ db connId sndMsgData
 
+createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO ()
+createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
+  DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId)
+
 getPendingMsgData :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData))
 getPendingMsgData db connId msgId = do
-  rq_ <- getRcvQueueByConnId_ db connId
+  rq_ <- L.head <$$> getRcvQueuesByConnId_ db connId
   (rq_,) <$$> firstRow pendingMsgData SEMsgNotFound getMsgData_
   where
     getMsgData_ =
@@ -541,16 +682,23 @@ getPendingMsgData db connId msgId = do
       let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
        in PendingMsgData {msgId, msgType, msgFlags, msgBody, internalTs}
 
-getPendingMsgs :: DB.Connection -> ConnId -> IO [InternalId]
-getPendingMsgs db connId =
+getPendingMsgs :: DB.Connection -> ConnId -> SndQueue -> IO [InternalId]
+getPendingMsgs db connId SndQueue {dbQueueId} =
   map fromOnly
-    <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ?" (Only connId)
+    <$> DB.query db "SELECT internal_id FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId)
 
-setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError SMP.MsgId)
-setMsgUserAck db connId agentMsgId = do
-  DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId)
-  firstRow fromOnly SEMsgNotFound $
-    DB.query db "SELECT broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
+deletePendingMsgs :: DB.Connection -> ConnId -> SndQueue -> IO ()
+deletePendingMsgs db connId SndQueue {dbQueueId} =
+  DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId)
+
+setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId))
+setMsgUserAck db connId agentMsgId = runExceptT $ do
+  liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId)
+  (dbRcvId, srvMsgId) <-
+    ExceptT . firstRow id SEMsgNotFound $
+      DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId)
+  rq <- ExceptT $ getRcvQueueById_ db connId dbRcvId
+  pure (rq, srvMsgId)
 
 getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg)
 getLastMsg db connId msgId =
@@ -576,6 +724,15 @@ deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
 deleteMsg db connId msgId =
   DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
 
+deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO ()
+deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId = do
+  DB.execute
+    db
+    "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND internal_id = ?"
+    (connId, dbQueueId, msgId)
+  (Only (cnt :: Int) : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
+  when (cnt == 0) $ deleteMsg db connId msgId
+
 createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
 createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 =
   DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
@@ -631,6 +788,50 @@ updateRatchet db connId rc skipped = do
         forM_ (M.assocs mks) $ \(msgN, mk) ->
           DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
 
+createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO AsyncCmdId
+createCommand db corrId connId srv cmd = do
+  DB.execute
+    db
+    "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command) VALUES (?,?,?,?,?,?)"
+    (host_, port_, corrId, connId, agentCommandTag cmd, cmd)
+  insertedRowId db
+  where
+    (host_, port_) =
+      case srv of
+        Just (SMPServer host port _) -> (Just host, Just port)
+        _ -> (Nothing, Nothing)
+
+insertedRowId :: DB.Connection -> IO Int64
+insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
+
+getPendingCommands :: DB.Connection -> ConnId -> IO [(Maybe SMPServer, [AsyncCmdId])]
+getPendingCommands db connId = do
+  map (\ids -> (fst $ head ids, map snd ids)) . groupBy ((==) `on` fst) . map srvCmdId
+    <$> DB.query
+      db
+      [sql|
+        SELECT c.host, c.port, s.key_hash, c.command_id
+        FROM commands c
+        LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
+        WHERE conn_id = ?
+        ORDER BY c.host, c.port, c.command_id ASC
+      |]
+      (Only connId)
+  where
+    srvCmdId (host, port, keyHash, cmdId) = (SMPServer <$> host <*> port <*> keyHash, cmdId)
+
+getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError (ACorrId, ConnId, AgentCommand))
+getPendingCommand db msgId = do
+  firstRow id SECmdNotFound $
+    DB.query
+      db
+      "SELECT corr_id, conn_id, command FROM commands WHERE command_id = ?"
+      (Only msgId)
+
+deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
+deleteCommand db cmdId =
+  DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
+
 createNtfToken :: DB.Connection -> NtfToken -> IO ()
 createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do
   upsertNtfServer_ db srv
@@ -743,9 +944,10 @@ getNtfSubscription db connId =
             _ -> Nothing
        in (NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}, action)
 
-createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> NtfActionTs -> IO ()
-createNtfSubscription db ntfSubscription action actionTs = do
+createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
+createNtfSubscription db ntfSubscription action = do
   let NtfSubscription {connId, smpServer = (SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} = ntfSubscription
+  actionTs <- liftIO getCurrentTime
   DB.execute
     db
     [sql|
@@ -760,9 +962,9 @@ createNtfSubscription db ntfSubscription action actionTs = do
   where
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
-supervisorUpdateNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> NtfActionTs -> IO ()
-supervisorUpdateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action actionTs = do
-  updatedAt <- getCurrentTime
+supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
+supervisorUpdateNtfSub db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
+  ts <- getCurrentTime
   DB.execute
     db
     [sql|
@@ -770,13 +972,13 @@ supervisorUpdateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServe
       SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
       WHERE conn_id = ?
     |]
-    ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, True, updatedAt, connId))
+    ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId))
   where
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
-supervisorUpdateNtfSubAction :: DB.Connection -> ConnId -> NtfSubAction -> NtfActionTs -> IO ()
-supervisorUpdateNtfSubAction db connId action actionTs = do
-  updatedAt <- getCurrentTime
+supervisorUpdateNtfAction :: DB.Connection -> ConnId -> NtfSubAction -> IO ()
+supervisorUpdateNtfAction db connId action = do
+  ts <- getCurrentTime
   DB.execute
     db
     [sql|
@@ -784,7 +986,7 @@ supervisorUpdateNtfSubAction db connId action actionTs = do
       SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
       WHERE conn_id = ?
     |]
-    (ntfSubAction, ntfSubSMPAction, actionTs, True, updatedAt, connId)
+    (ntfSubAction, ntfSubSMPAction, ts, True, ts, connId)
   where
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
@@ -931,6 +1133,10 @@ getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId}
     res (connId, Just rcvNtfDhSecret) = Right (connId, rcvNtfDhSecret)
     res _ = Left SEConnNotFound
 
+setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()
+setConnectionNtfs db connId enableNtfs =
+  DB.execute db "UPDATE connections SET enable_ntfs = ? WHERE conn_id = ?" (enableNtfs, connId)
+
 -- * Auxiliary helpers
 
 instance ToField QueueStatus where toField = toField . serializeQueueStatus
@@ -985,6 +1191,18 @@ instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList
 
 instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP
 
+instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode
+
+instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField AgentCommand where toField = toField . strEncode
+
+instance FromField AgentCommand where fromField = blobFieldParser strP
+
+instance ToField AgentCommandTag where toField = toField . strEncode
+
+instance FromField AgentCommandTag where fromField = blobFieldParser strP
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -1056,91 +1274,126 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
-insertRcvQueue_ dbConn connId RcvQueue {..} = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO Int64
+insertRcvQueue_ db connId' RcvQueue {..} = do
+  qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')
   DB.execute
-    dbConn
+    db
     [sql|
       INSERT INTO rcv_queues
-        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status) VALUES (?,?,?,?,?,?,?,?,?,?);
+        (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
-    (host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
+    ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion))
+  pure qId
 
 -- * createSndConn helpers
 
-insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()
-insertSndQueue_ dbConn connId SndQueue {..} = do
+insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO Int64
+insertSndQueue_ db connId' SndQueue {..} = do
+  qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')
   DB.execute
-    dbConn
+    db
     [sql|
       INSERT INTO snd_queues
-        (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status) VALUES (?,?,?,?,?, ?,?, ?,?);
+        (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
-    (host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
+    ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion))
+  pure qId
+
+newQueueId_ :: [Only Int64] -> Int64
+newQueueId_ [] = 1
+newQueueId_ (Only maxId : _) = maxId + 1
 
 -- * getConn helpers
 
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
-getConn dbConn connId =
-  getConnData_ dbConn connId >>= \case
+getConn db connId = getAnyConn db connId False
+
+getAnyConn :: DB.Connection -> ConnId -> Bool -> IO (Either StoreError SomeConn)
+getAnyConn dbConn connId deleted' =
+  getConnData dbConn connId >>= \case
     Nothing -> pure $ Left SEConnNotFound
-    Just (connData, cMode) -> do
-      rQ <- getRcvQueueByConnId_ dbConn connId
-      sQ <- getSndQueueByConnId_ dbConn connId
-      pure $ case (rQ, sQ, cMode) of
-        (Just rcvQ, Just sndQ, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)
-        (Just rcvQ, Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)
-        (Nothing, Just sndQ, CMInvitation) -> Right $ SomeConn SCSnd (SndConnection connData sndQ)
-        (Just rcvQ, Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection connData rcvQ)
-        _ -> Left SEConnNotFound
+    Just (cData@ConnData {deleted}, cMode)
+      | deleted /= deleted' -> pure $ Left SEConnNotFound
+      | otherwise -> do
+        rQ <- getRcvQueuesByConnId_ dbConn connId
+        sQ <- getSndQueuesByConnId_ dbConn connId
+        pure $ case (rQ, sQ, cMode) of
+          (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
+          (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
+          (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
+          (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
+          (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
+          _ -> Left SEConnNotFound
 
-getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
-getConnData_ dbConn connId' =
-  connData
-    <$> DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, duplex_handshake FROM connections WHERE conn_id = ?;" (Only connId')
+getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData dbConn connId' =
+  maybeFirstRow cData $ DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId')
   where
-    connData [(connId, cMode, connAgentVersion, duplexHandshake)] = Just (ConnData {connId, connAgentVersion, duplexHandshake}, cMode)
-    connData _ = Nothing
+    cData (connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode)
 
-getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)
-getRcvQueueByConnId_ dbConn connId =
-  listToMaybe . map rcvQueue
+setConnDeleted :: DB.Connection -> ConnId -> IO ()
+setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
+
+-- | returns all connection queues, the first queue is the primary one
+getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
+getRcvQueuesByConnId_ db connId =
+  L.nonEmpty . sortBy primaryFirst . map toRcvQueue
+    <$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ?") (Only connId)
+  where
+    primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} =
+      -- the current primary queue is ordered first, the next primary - second
+      compare (Down p) (Down p') <> compare i i'
+
+rcvQueueQuery :: Query
+rcvQueueQuery =
+  [sql|
+    SELECT s.key_hash, q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
+      q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
+      q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version,
+      q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
+    FROM rcv_queues q
+    INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+  |]
+
+toRcvQueue ::
+  (C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
+    :. (Int64, Bool, Maybe Int64, Maybe Version)
+    :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
+  RcvQueue
+toRcvQueue ((keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
+  let server = SMPServer host port keyHash
+      smpClientVersion = fromMaybe 1 smpClientVersion_
+      clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
+        (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
+        _ -> Nothing
+   in RcvQueue {connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds}
+
+getRcvQueueById_ :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
+getRcvQueueById_ db connId dbRcvId =
+  firstRow toRcvQueue SEConnNotFound $
+    DB.query db (rcvQueueQuery <> " WHERE conn_id = ? AND rcv_queue_id = ?") (connId, dbRcvId)
+
+-- | returns all connection queues, the first queue is the primary one
+getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue))
+getSndQueuesByConnId_ dbConn connId =
+  L.nonEmpty . sortBy primaryFirst . map sndQueue
     <$> DB.query
       dbConn
       [sql|
-        SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
-          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
-          q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
-        FROM rcv_queues q
-        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
-        WHERE q.conn_id = ?;
-      |]
-      (Only connId)
-  where
-    rcvQueue ((keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
-      let server = SMPServer host port keyHash
-          clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
-            (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
-            _ -> Nothing
-       in RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, clientNtfCreds}
-
-getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
-getSndQueueByConnId_ dbConn connId =
-  sndQueue
-    <$> DB.query
-      dbConn
-      [sql|
-        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status
+        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
         FROM snd_queues q
         INNER JOIN servers s ON q.host = s.host AND q.port = s.port
         WHERE q.conn_id = ?;
       |]
       (Only connId)
   where
-    sndQueue [(keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)] =
+    sndQueue ((keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) =
       let server = SMPServer host port keyHash
-       in Just SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status}
-    sndQueue _ = Nothing
+       in SndQueue {connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion}
+    primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} =
+      -- the current primary queue is ordered first, the next primary - second
+      compare (Down p) (Down p') <> compare i i'
 
 -- * updateRcvIds helpers
 
@@ -1194,22 +1447,23 @@ insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody,
       ":msg_body" := msgBody
     ]
 
-insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
-insertRcvMsgDetails_ dbConn connId RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do
+insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
+insertRcvMsgDetails_ dbConn connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do
   let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta
   DB.executeNamed
     dbConn
     [sql|
       INSERT INTO rcv_messages
-        ( conn_id, internal_rcv_id, internal_id, external_snd_id,
+        ( conn_id, rcv_queue_id, internal_rcv_id, internal_id, external_snd_id,
           broker_id, broker_ts,
           internal_hash, external_prev_snd_hash, integrity)
       VALUES
-        (:conn_id,:internal_rcv_id,:internal_id,:external_snd_id,
+        (:conn_id,:rcv_queue_id,:internal_rcv_id,:internal_id,:external_snd_id,
          :broker_id,:broker_ts,
          :internal_hash,:external_prev_snd_hash,:integrity);
     |]
     [ ":conn_id" := connId,
+      ":rcv_queue_id" := dbQueueId,
       ":internal_rcv_id" := internalRcvId,
       ":internal_id" := fst recipient,
       ":external_snd_id" := sndMsgId,

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,29 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
   )
 where
 
-import Control.Monad (forM_)
-import Data.List (intercalate, sortBy)
-import Data.Ord (comparing)
+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.Encoding.String
+import Simplex.Messaging.Transport.Client (TransportHost)
 
 data Migration = Migration {name :: String, up :: Text}
   deriving (Show)
@@ -39,12 +49,16 @@ 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)
   ]
 
 -- | The list of migrations in ascending order by date
 app :: [Migration]
-app = sortBy (comparing name) $ map migration schemaMigrations
+app = sortOn name $ map migration schemaMigrations
   where
     migration (name, query) = Migration {name = name, up = fromQuery query}
 
@@ -54,11 +68,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/agent_schema.sql

@@ -20,7 +20,9 @@ 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)
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -40,6 +42,9 @@ 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,
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -57,6 +62,9 @@ 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,
   PRIMARY KEY(host, port, snd_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
@@ -88,6 +96,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 +114,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,
@@ -192,3 +202,29 @@ CREATE TABLE ntf_subscriptions(
   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,
+  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
+);

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.Agent.TRcvQueues 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 (..))
+import Simplex.Messaging.Protocol (RecipientId, SMPServer)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+
+newtype TRcvQueues = TRcvQueues (TMap (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@RcvQueue {server, rcvId} (TRcvQueues qs) = TM.insert (server, rcvId) rq qs
+
+deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
+deleteQueue RcvQueue {server, rcvId} (TRcvQueues qs) = TM.delete (server, rcvId) qs
+
+getSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue]
+getSrvQueues srv (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
+  where
+    addQ qs' rq@RcvQueue {server} = if srv == server then rq : qs' else qs'
+
+getDelSrvQueues :: SMPServer -> TRcvQueues -> STM ([RcvQueue], Set ConnId)
+getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ (([], S.empty), M.empty)
+  where
+    addQ (removed@(remQs, remConns), qs') rq@RcvQueue {connId, server, rcvId}
+      | srv == server = ((rq : remQs, S.insert connId remConns), qs')
+      | otherwise = (removed, M.insert (server, rcvId) rq qs')

src/Simplex/Messaging/Client.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
@@ -25,10 +26,12 @@
 -- 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),
+    ProtocolClient (thVersion, sessionId, sessionTs),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
+    clientServer,
+    transportHost',
 
     -- * SMP protocol command functions
     createSMPQueue,
@@ -50,7 +53,11 @@ module Simplex.Messaging.Client
     -- * Supporting types and client configuration
     ProtocolClientError (..),
     ProtocolClientConfig (..),
+    NetworkConfig (..),
     defaultClientConfig,
+    defaultNetworkConfig,
+    transportClientConfig,
+    chooseTransportHost,
     ServerTransmission,
   )
 where
@@ -62,24 +69,31 @@ 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.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)
 
@@ -87,15 +101,21 @@ import System.Timeout (timeout)
 --
 -- Use 'getSMPClient' to connect to an SMP server and create a client handle.
 data ProtocolClient msg = ProtocolClient
-  { action :: Async (),
-    connected :: TVar Bool,
+  { action :: Maybe (Async ()),
     sessionId :: SessionId,
+    sessionTs :: UTCTime,
     thVersion :: Version,
+    client_ :: PClient msg
+  }
+
+data PClient msg = PClient
+  { connected :: TVar Bool,
     protocolServer :: ProtoServer msg,
+    transportHost :: TransportHost,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TMap CorrId (Request msg),
-    sndQ :: TBQueue (NonEmpty (SentRawTransmission)),
+    sndQ :: TBQueue (NonEmpty SentRawTransmission),
     rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
     msgQ :: Maybe (TBQueue (ServerTransmission msg))
   }
@@ -108,18 +128,71 @@ 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)
 
+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,
+    -- | 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)
+    smpPingInterval :: 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}
+
+defaultNetworkConfig :: NetworkConfig
+defaultNetworkConfig =
+  NetworkConfig
+    { socksProxy = Nothing,
+      hostMode = HMOnionViaSocks,
+      requiredHostMode = False,
+      tcpConnectTimeout = 7_500_000,
+      tcpTimeout = 5_000_000,
+      tcpKeepAlive = Just defaultKeepAliveOpts,
+      smpPingInterval = 600_000_000, -- 10min
+      logTLSErrors = False
+    }
+
+transportClientConfig :: NetworkConfig -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
+  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
+
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
     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
   }
@@ -130,9 +203,7 @@ defaultClientConfig =
   ProtocolClientConfig
     { qSize = 64,
       defaultTransport = ("443", transport @TLS),
-      tcpTimeout = 5_000_000,
-      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPing = 600_000_000, -- 10min
+      networkConfig = defaultNetworkConfig,
       smpServerVRange = supportedSMPServerVRange
     }
 
@@ -143,30 +214,52 @@ data Request msg = Request
 
 type Response msg = Either ProtocolClientError msg
 
+chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError 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 msg -> String
+clientServer = B.unpack . strEncode . protocolServer . client_
+
+transportHost' :: ProtocolClient msg -> TransportHost
+transportHost' = transportHost . client_
+
 -- | 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 msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
+  case chooseTransportHost networkConfig (host protocolServer) 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 msg)
+    mkProtocolClient transportHost = do
       connected <- newTVar False
       clientCorrId <- newTVar 0
       sentCommands <- TM.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        ProtocolClient
-          { action = undefined,
-            sessionId = undefined,
-            thVersion = undefined,
-            connected,
+        PClient
+          { connected,
             protocolServer,
+            transportHost,
             tcpTimeout,
             clientCorrId,
             sentCommands,
@@ -175,16 +268,17 @@ 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 msg -> IO (Either ProtocolClientError (ProtocolClient msg))
+    runClient (port', ATransport t) useHost c = do
+      cVar <- newEmptyTMVarIO
+      let tcConfig = transportClientConfig networkConfig
       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 useHost port' (Just $ keyHash protocolServer) (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
 
@@ -194,35 +288,35 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
       "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 =
+    client :: forall c. Transport c => TProxy c -> PClient msg -> TMVar (Either ProtocolClientError (ProtocolClient msg)) -> c -> IO ()
+    client _ c cVar h =
       runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
-        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
+        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 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 ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
     ping :: ProtocolClient msg -> IO ()
     ping c = forever $ do
-      threadDelay smpPing
+      threadDelay smpPingInterval
       runExceptT $ sendProtocolCommand c Nothing "" protocolPing
 
     process :: ProtocolClient msg -> IO ()
-    process c = forever $ atomically (readTBQueue $ rcvQ c) >>= mapM_ (processMsg c)
+    process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
 
     processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
-    processMsg c@ProtocolClient {sentCommands} (_, _, (corrId, qId, respOrErr)) =
+    processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, qId, respOrErr)) =
       if B.null $ bs corrId
         then sendMsg respOrErr
         else do
@@ -242,12 +336,11 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
         sendMsg :: Either ErrorType 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
 
 -- | Disconnects client from the server and terminates client threads.
 closeProtocolClient :: ProtocolClient msg -> IO ()
-closeProtocolClient = uninterruptibleCancel . action
+closeProtocolClient = mapM_ uninterruptibleCancel . action
 
 -- | SMP client error type.
 data ProtocolClientError
@@ -268,6 +361,8 @@ 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
@@ -285,9 +380,10 @@ createSMPQueue ::
   RcvPrivateSignKey ->
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
+  Maybe BasicAuth ->
   ExceptT ProtocolClientError IO QueueIdsKeys
-createSMPQueue c rpKey rKey dhKey =
-  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
+createSMPQueue c rpKey rKey dhKey auth =
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
     IDS qik -> pure qik
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
@@ -313,10 +409,10 @@ subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
       Left e -> pure $ Left e
 
 writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
-writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
+writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
 
 serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
-serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
+serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {protocolServer}} entityId message =
   (protocolServer, 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
@@ -420,7 +516,7 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
 -- | Send multiple commands with batching and collect responses
 sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
-sendProtocolCommands c@ProtocolClient {sndQ, tcpTimeout} cs = do
+sendProtocolCommands c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} cs = do
   ts <- mapM (runExceptT . mkTransmission c) cs
   mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
   forConcurrently ts $ \case
@@ -431,7 +527,7 @@ sendProtocolCommands c@ProtocolClient {sndQ, tcpTimeout} cs = do
 
 -- | Send Protocol command
 sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
-sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
+sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} pKey qId cmd = do
   (t, r) <- mkTransmission c (pKey, qId, cmd)
   ExceptT $ sendRecv t r
   where
@@ -442,9 +538,9 @@ sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
         withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
 
 mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
-mkTransmission ProtocolClient {clientCorrId, sessionId, thVersion, sentCommands} (pKey, qId, cmd) = do
+mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do
   corrId <- liftIO $ atomically getNextCorrId
-  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
+  let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
   r <- liftIO . atomically $ mkRequest corrId
   pure (t, r)
   where
@@ -452,12 +548,8 @@ mkTransmission ProtocolClient {clientCorrId, sessionId, thVersion, sentCommands}
     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 -> pure (Nothing, t)
-      Just pk -> do
-        sig <- liftError PCESignatureError $ C.sign pk t
-        return (Just sig, t)
+    signTransmission :: ByteString -> SentRawTransmission
+    signTransmission t = ((`C.sign` t) <$> pKey, t)
     mkRequest :: CorrId -> STM (TMVar (Response msg))
     mkRequest corrId = do
       r <- newEmptyTMVar

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
@@ -125,8 +126,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
 
     waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError 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
@@ -161,8 +162,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
     connectClient :: ExceptT ProtocolClientError IO SMPClient
     connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: SMPClient -> IO ()
+    clientDisconnected _ = do
       removeClientAndSubs >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
@@ -264,7 +265,7 @@ 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 smp ((party, queueId), privKey) = subscribe_ smp privKey queueId

src/Simplex/Messaging/Crypto.hs

@@ -67,7 +67,9 @@ module Simplex.Messaging.Crypto
 
     -- * key encoding/decoding
     encodePubKey,
+    decodePubKey,
     encodePrivKey,
+    decodePrivKey,
     pubKeyBytes,
 
     -- * sign/verify
@@ -691,6 +693,8 @@ data 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
@@ -802,9 +806,12 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
   aead <- initAEAD @AES256 aesKey ivBytes
   liftEither . unPad =<< maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg authTag)
 
+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 +819,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
@@ -883,12 +890,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.
 --
@@ -957,11 +964,7 @@ pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
 pseudoRandomCbNonce gVar = CbNonce <$> 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

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

@@ -6,6 +6,7 @@ module Simplex.Messaging.Encoding.String
     StrEncoding (..),
     Str (..),
     strP_,
+    _strP,
     strToJSON,
     strToJEncoding,
     strParseJSON,
@@ -96,7 +97,7 @@ instance StrEncoding Word16 where
 instance StrEncoding Char where
   strEncode = smpEncode
   {-# INLINE strEncode #-}
-  strP = strP
+  strP = smpP
   {-# INLINE strP #-}
 
 instance StrEncoding Bool where
@@ -171,6 +172,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/Protocol.hs

@@ -23,6 +23,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
@@ -332,12 +333,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 +387,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,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -14,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.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 {} ->
@@ -87,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
@@ -99,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
@@ -110,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)
@@ -128,7 +188,7 @@ 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
       let smpQueue = SMPQueueNtf srv ntfId
@@ -137,33 +197,37 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
           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 -> ProtocolClientError -> M ()
     handleSubError smpQueue = \case
       PCEProtocolError AUTH -> updateSubStatus smpQueue NSAuth
       PCEProtocolError e -> updateErr "SMP error " e
@@ -172,10 +236,11 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
       PCETransportError e -> updateErr "TransportError " e
       PCESignatureError e -> updateErr "SignatureError " 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
@@ -187,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
@@ -215,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
@@ -239,15 +309,15 @@ 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
   ts <- tGet th
   forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
@@ -262,7 +332,7 @@ receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
   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)]
@@ -273,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 NtfCmd -> NtfCmd -> M VerificationResult
 verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
   st <- asks store
   case cmd of
@@ -295,13 +364,11 @@ 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
@@ -309,14 +376,13 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = 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} ->
@@ -324,17 +390,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"
@@ -347,6 +413,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
@@ -368,6 +435,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"
@@ -386,6 +454,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"
@@ -395,6 +465,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"
@@ -434,13 +505,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
@@ -454,20 +526,51 @@ 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
+    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,

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

@@ -34,7 +34,6 @@ import Data.Int (Int64)
 import Data.Map.Strict (Map)
 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 GHC.Generics (Generic)
@@ -49,6 +48,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
 import Simplex.Messaging.Protocol (EncNMsgMeta)
 import Simplex.Messaging.Transport.HTTP2.Client
+import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
@@ -90,14 +90,14 @@ 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
+  -- | PNAlert Text
   | PNCheckMessages
   deriving (Show)
 
@@ -287,15 +287,14 @@ 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
@@ -358,7 +357,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/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

@@ -38,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,
@@ -65,12 +64,17 @@ module Simplex.Messaging.Protocol
     PrivHeader (..),
     Protocol (..),
     ProtocolType (..),
+    AProtocolType (..),
+    ProtocolTypeI (..),
     ProtocolServer (..),
     ProtoServer,
     SMPServer,
     pattern SMPServer,
+    SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    ProtoServerWithAuth (..),
+    BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
     QueueId,
@@ -111,6 +115,12 @@ module Simplex.Messaging.Protocol
     _smpP,
     encodeRcvMsgBody,
     clientRcvMsgBodyP,
+    legacyEncodeServer,
+    legacyServerP,
+    legacyStrEncodeServer,
+    sameSrvAddr,
+    sameSrvAddr',
+    noAuthSrv,
 
     -- * TCP transport functions
     tPut,
@@ -124,16 +134,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.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
-import Data.Maybe (isNothing)
+import Data.Maybe (isJust, isNothing)
 import Data.String
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
@@ -146,15 +158,16 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
 import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.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
@@ -244,7 +257,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
@@ -291,12 +304,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} =
@@ -316,44 +334,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
 
@@ -365,7 +411,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,
@@ -555,18 +603,28 @@ 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 #-}
 
+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
   deriving (Eq, Ord, Show)
 
@@ -575,7 +633,7 @@ instance StrEncoding ProtocolType where
     PSMP -> "smp"
     PNTF -> "ntf"
   strP =
-    A.takeTill (== ':') >>= \case
+    A.takeTill (\c -> c == ':' || c == ' ') >>= \case
       "smp" -> pure PSMP
       "ntf" -> pure PNTF
       _ -> fail "bad ProtocolType"
@@ -592,6 +650,11 @@ 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
@@ -615,6 +678,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
@@ -630,7 +697,7 @@ instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
   { scheme :: SProtocolType p,
-    host :: HostName,
+    host :: NonEmpty TransportHost,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
@@ -648,17 +715,87 @@ 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
 
+newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
+  deriving (Eq, 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 (ProtocolServer p) (Maybe BasicAuth)
+  deriving (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)
 
@@ -667,7 +804,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)
@@ -751,7 +888,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
@@ -829,7 +966,13 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
 instance PartyI p => ProtocolEncoding (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)
@@ -877,7 +1020,11 @@ instance ProtocolEncoding Cmd where
   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
@@ -891,7 +1038,7 @@ 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
@@ -1013,26 +1160,33 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> NonEmpty (SentRawTransmission) -> IO (NonEmpty (Either TransportError ()))
+tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
 tPut th trs
   | batch th = tPutBatch [] $ L.map tEncode trs
-  | otherwise = forM trs $ tPutBlock th . tEncode
+  | otherwise = forM (L.toList trs) $ tPutLog . tEncode
   where
-    tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO (NonEmpty (Either TransportError ()))
+    tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO [Either TransportError ()]
     tPutBatch rs ts = do
       let (n, s, ts_) = encodeBatch 0 "" ts
-      r <- if n == 0 then pure [Left TELargeMsg] else replicate n <$> tPutBlock th (lenEncode n `B.cons` s)
+      r <- if n == 0 then largeMsg else replicate n <$> tPutLog (lenEncode n `B.cons` s)
       let rs' = rs <> r
       case ts_ of
         Just ts' -> tPutBatch rs' ts'
-        _ -> pure $ L.fromList rs'
+        _ -> 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
+         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'

src/Simplex/Messaging/Server.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -42,6 +41,7 @@ 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, partitionEithers)
@@ -50,12 +50,8 @@ 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)
@@ -69,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)
@@ -91,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
@@ -100,13 +96,14 @@ 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
   raceAny_
@@ -116,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.
@@ -127,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
@@ -144,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)]
           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
@@ -167,17 +164,17 @@ smpServer started = do
           atomically (getMsgQueue ms rId quota)
             >>= atomically . (`deleteExpiredMsgs` old)
 
-    serverStatsThread_ :: ServerConfig -> [m ()]
+    serverStatsThread_ :: ServerConfig -> [M ()]
     serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
       [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> FilePath -> m ()
+    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)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues} <- asks serverStats
       let interval = 1000000 * logInterval
       withFile statsFilePath AppendMode $ \h -> liftIO $ do
         hSetBuffering h LineBuffering
@@ -189,19 +186,11 @@ smpServer started = do
           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
-          hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayMsgQueues', weekMsgQueues', monthMsgQueues']
+          ps <- atomically $ periodStatCounts activeQueues ts
+          hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayCount ps, weekCount ps, monthCount ps]
           threadDelay interval
-      where
-        periodCount :: Int -> TVar (Set RecipientId) -> STM String
-        periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
-        periodCount _ _ = pure ""
 
-    runClient :: Transport c => TProxy c -> c -> m ()
+    runClient :: Transport c => TProxy c -> c -> M ()
     runClient _ h = do
       kh <- asks serverIdentity
       smpVRange <- asks $ smpServerVRange . config
@@ -209,24 +198,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
@@ -239,13 +228,13 @@ 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 :: forall c m. (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
   ts <- L.toList <$> tGet th
   atomically . writeTVar activeAt =<< liftIO getSystemTime
@@ -253,7 +242,7 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
   write sndQ $ fst as
   write rcvQ $ snd as
   where
-    cmdAction :: SignedTransmission Cmd -> m (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
+    cmdAction :: SignedTransmission 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)
@@ -264,10 +253,9 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
               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
   ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-  -- TODO the line below can return Lefts, but we ignore it and do not disconnect the client
   void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
   atomically . writeTVar activeAt =<< liftIO getSystemTime
   where
@@ -276,7 +264,7 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
       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
@@ -287,17 +275,16 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
 
 data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 
-verifyTransmission ::
-  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m VerificationResult
+verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
 verifyTransmission sig_ signed queueId cmd = do
   case cmd of
-    Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` 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 $ VRVerified Nothing
     Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
   where
-    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m VerificationResult
+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
     verifyCmd party f = do
       st <- asks queueStore
       q_ <- atomically (getQueue st party queueId)
@@ -351,11 +338,15 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
         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))
+              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)
@@ -366,7 +357,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}
@@ -395,7 +386,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                 Right _ -> do
                   withLog (`logCreateById` rId)
                   stats <- asks serverStats
-                  atomically $ modifyTVar (qCreated stats) (+ 1)
+                  atomically $ modifyTVar' (qCreated stats) (+ 1)
                   subscribeQueue qr rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
@@ -410,14 +401,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
@@ -441,14 +432,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 :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
-        subscribeQueue qr rId =
+        subscribeQueue qr rId = do
           atomically (TM.lookup rId subscriptions) >>= \case
             Nothing ->
-              atomically newSub >>= deliver
+              newSub >>= deliver
             Just sub ->
               readTVarIO sub >>= \case
                 Sub {subThread = ProhibitSub} ->
@@ -457,20 +448,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 qr rId sub q msg_
+              deliverMessage "SUB" qr rId sub q msg_
 
         getMessage :: QueueRec -> m (Transmission BrokerMsg)
-        getMessage qr =
+        getMessage qr = time "GET" $ do
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= getMessage_
@@ -490,7 +481,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               pure s
             getMessage_ :: Sub -> m (Transmission BrokerMsg)
             getMessage_ s = do
-              q <- getStoreMsgQueue queueId
+              q <- getStoreMsgQueue "GET" queueId
               atomically $
                 tryPeekMsg q >>= \case
                   Just msg ->
@@ -502,20 +493,20 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
         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 :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
-        acknowledgeMsg qr msgId = do
+        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
@@ -524,7 +515,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                     _ -> do
                       (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
                       when msgDeleted updateStats
-                      deliverMessage qr queueId sub q msg_
+                      deliverMessage "ACK" qr queueId sub q msg_
                 _ -> pure $ err NO_MSG
           where
             getDelivered :: TVar Sub -> STM (Maybe Sub)
@@ -537,16 +528,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             updateStats :: m ()
             updateStats = do
               stats <- asks serverStats
-              atomically $ modifyTVar (msgRecv stats) (+ 1)
-              atomically $ updateActiveQueues 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)
+              atomically $ modifyTVar' (msgRecv stats) (+ 1)
+              atomically $ updatePeriodStats (activeQueues stats) queueId
 
         sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
         sendMessage qr msgFlags msgBody
@@ -554,25 +537,22 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
           | otherwise = case status qr of
             QueueOff -> return $ err AUTH
             QueueActive ->
-              mapM mkMessage (C.maxLenBS msgBody) >>= \case
+              case C.maxLenBS msgBody of
                 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
+                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
+                      when (notification msgFlags) $
+                        atomically . trySendNotification msg =<< asks idsDrg
+                      stats <- asks serverStats
+                      atomically $ modifyTVar' (msgSent stats) (+ 1)
+                      atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
                       pure ok
-                  when (sent == 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
@@ -580,6 +560,12 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               msgTs <- liftIO getSystemTime
               pure $ Message msgId msgTs msgFlags body
 
+            expireMessages :: MsgQueue -> m ()
+            expireMessages q = do
+              msgExp <- asks $ messageExpiration . config
+              old <- liftIO $ mapM expireBeforeEpoch msgExp
+              atomically $ mapM_ (deleteExpiredMsgs q) old
+
             trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
             trySendNotification msg ntfNonceDrg =
               forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
@@ -587,19 +573,21 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
 
             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)]
+              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 ()
 
-            mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
-            mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = 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 :: QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
-        deliverMessage qr rId sub q msg_ = do
+        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
@@ -611,35 +599,44 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
           where
             forkSub :: m ()
             forkSub = do
-              atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
+              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
@@ -649,7 +646,7 @@ 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 $
             deleteQueue st queueId >>= \case
               Left e -> pure $ err e
@@ -669,6 +666,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
@@ -716,8 +725,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
@@ -743,7 +755,9 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          atomically $ setServerStatsData s d
+          atomically $ setServerStats s d
           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,214 +13,133 @@ 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.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 Simplex.Messaging.Util (whenM)
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
+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
-  clearDirs 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,
@@ -236,57 +155,76 @@ 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
+
+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 = whenM (doesDirectoryExist path) $ 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 <> ")..."
 
-clearDirs :: ServerCLIConfig cfg -> IO ()
-clearDirs ServerCLIConfig {cfgDir, logDir} = do
-  clearDirIfExists cfgDir
-  clearDirIfExists logDir
-  where
-    clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
+deleteDirIfExists :: FilePath -> IO ()
+deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
 
-printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
-printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
+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

@@ -39,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),
@@ -65,7 +67,8 @@ data ServerConfig = ServerConfig
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
     -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange
+    smpServerVRange :: VersionRange,
+    logTLSErrors :: Bool
   }
 
 defaultMessageExpiration :: ExpirationConfig
@@ -161,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,285 @@
+{-# 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 = case lookupValue "AUTH" "create_password" ini of
+                Right auth -> either error Just . strDecode $ encodeUtf8 auth
+                _ -> Nothing,
+              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 Bool
+tryDelMsg mq msgId' =
+  tryPeekMsg mq >>= \case
+    Just msg
+      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure True
+      | otherwise -> pure False
+    _ -> pure False
 
-  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 (Bool, Maybe Message)
+tryDelPeekMsg mq msgId' =
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> (True,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
+      | otherwise -> pure (False, msg_)
+    _ -> pure (False, 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,5 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Server.Stats where
 
@@ -8,7 +10,9 @@ 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 +24,7 @@ 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
   }
 
 data ServerStatsData = ServerStatsData
@@ -32,9 +34,7 @@ data ServerStatsData = ServerStatsData
     _qDeleted :: Int,
     _msgSent :: Int,
     _msgRecv :: Int,
-    _dayMsgQueues :: Set RecipientId,
-    _weekMsgQueues :: Set RecipientId,
-    _monthMsgQueues :: Set RecipientId
+    _activeQueues :: PeriodStatsData RecipientId
   }
 
 newServerStats :: UTCTime -> STM ServerStats
@@ -45,10 +45,8 @@ 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
+  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
@@ -58,25 +56,21 @@ 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
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
 
-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)
 
 instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues} =
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "qCreated=" <> strEncode _qCreated,
@@ -84,9 +78,8 @@ instance StrEncoding ServerStatsData where
         "qDeleted=" <> strEncode _qDeleted,
         "msgSent=" <> strEncode _msgSent,
         "msgRecv=" <> strEncode _msgRecv,
-        "dayMsgQueues=" <> strEncode _dayMsgQueues,
-        "weekMsgQueues=" <> strEncode _weekMsgQueues,
-        "monthMsgQueues=" <> strEncode _monthMsgQueues
+        "activeQueues:",
+        strEncode _activeQueues
       ]
   strP = do
     _fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -95,7 +88,81 @@ 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}
+    r <- optional ("activeQueues:" <* A.endOfLine)
+    _activeQueues <- case r of
+      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}
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
+
+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
+  }
+
+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,7 +37,7 @@ 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.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
 import Simplex.Messaging.Transport (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 (..),
@@ -74,12 +75,14 @@ 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)
@@ -96,10 +99,10 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 4
+supportedSMPServerVRange = mkVersionRange 1 5
 
 simplexMQVersion :: String
-simplexMQVersion = "3.1.1"
+simplexMQVersion = showVersion SMQ.version
 
 -- * Transport connection class
 
@@ -153,12 +156,14 @@ data TLS = TLS
     getLock :: TMVar ()
   }
 
-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
@@ -211,7 +216,7 @@ instance Transport TLS where
       $ do
         b <- readChunks =<< readTVarIO buffer
         let (s, b') = B.splitAt n b
-        atomically $ writeTVar buffer b'
+        atomically $ writeTVar buffer $! b'
         pure s
     where
       readChunks :: ByteString -> IO ByteString
@@ -234,7 +239,7 @@ instance Transport TLS where
       $ 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
+        atomically $ writeTVar buffer $! B.drop 1 b' -- drop '\n' we made a break at
         pure $ trimCR s
     where
       readChunks :: ByteString -> IO ByteString

src/Simplex/Messaging/Transport/Client.hs

@@ -1,43 +1,135 @@
+{-# 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.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.takeTill (== '.') <*> A.string ".onion"),
+        THDomainName . B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
+      ]
+    where
+      ipNum = A.decimal <* A.char '.'
+
+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 -> 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 -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
+runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} 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 $ 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 +139,52 @@ 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 -> SocksHostAddress -> ServiceName -> IO Socket
+connectSocksClient (SocksProxy addr) hostAddr _port = do
+  let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
+  fst <$> 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/Client.hs

@@ -19,14 +19,13 @@ 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.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
-import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
 import UnliftIO.STM
 import UnliftIO.Timeout
 
 data HTTP2Client = HTTP2Client
-  { action :: Async (),
+  { action :: Maybe (Async ()),
     connected :: TVar Bool,
     host :: HostName,
     port :: ServiceName,
@@ -43,7 +42,7 @@ data HTTP2Response = HTTP2Response
 data HTTP2ClientConfig = HTTP2ClientConfig
   { qSize :: Natural,
     connTimeout :: Int,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
+    transportConfig :: TransportClientConfig,
     caStoreFile :: FilePath,
     suportedTLSParams :: T.Supported
   }
@@ -54,7 +53,7 @@ defaultHTTP2ClientConfig =
   HTTP2ClientConfig
     { qSize = 64,
       connTimeout = 10000000,
-      tcpKeepAlive = Nothing,
+      transportConfig = TransportClientConfig Nothing Nothing True,
       caStoreFile = "/etc/ssl/cert.pem",
       suportedTLSParams = http2TLSParams
     }
@@ -63,7 +62,7 @@ data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | H
   deriving (Show)
 
 getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
+getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout, caStoreFile, suportedTLSParams} disconnected =
   (atomically mkHTTPS2Client >>= runClient)
     `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
   where
@@ -71,7 +70,7 @@ getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, ca
     mkHTTPS2Client = do
       connected <- newTVar False
       reqQ <- newTBQueue $ qSize config
-      pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
+      pure HTTP2Client {action = Nothing, connected, host, port, config, reqQ}
 
     runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
     runClient c = do
@@ -80,11 +79,11 @@ getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, ca
       when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
       action <-
         async $
-          runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
+          runHTTP2Client suportedTLSParams caStore transportConfig host port (client c cVar)
             `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
       conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
       pure $ case conn_ of
-        Just (Right ()) -> Right c {action}
+        Just (Right ()) -> Right c {action = Just action}
         Just (Left e) -> Left e
         Nothing -> Left HCNetworkError1
 
@@ -111,8 +110,7 @@ getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, ca
 
 -- | 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
@@ -120,9 +118,9 @@ sendRequest HTTP2Client {reqQ, config} req = do
   atomically $ writeTBQueue reqQ (req, resp)
   maybe (Left HCResponseTimeout) Right <$> (connTimeout config `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 ->
+runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> HostName -> ServiceName -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
+runHTTP2Client tlsParams caStore tcConfig host port client =
+  runTLSTransportClient tlsParams caStore tcConfig (THDomainName host) port Nothing $ \c ->
     withTlsConfig c 16384 (`run` client)
   where
     run = H.run $ ClientConfig "https" (B.pack host) 20

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

@@ -25,7 +25,8 @@ data HTTP2ServerConfig = HTTP2ServerConfig
     serverSupported :: T.Supported,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
-    certificateFile :: FilePath
+    certificateFile :: FilePath,
+    logTLSErrors :: Bool
   }
   deriving (Show)
 
@@ -42,12 +43,12 @@ data HTTP2Server = HTTP2Server
   }
 
 getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, 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
+    runHTTP2Server started http2Port tlsServerParams logTLSErrors $ \r sendResponse -> do
       reqBody <- getRequestBody r ""
       reqTrailers <- H.getRequestTrailers r
       atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
@@ -62,9 +63,9 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertifica
 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 -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port serverParams logTLSErrors http2Server =
+  runTransportServer started port serverParams logTLSErrors $ \c -> withTlsConfig c 16384 (`H.run` server)
   where
     server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
     server req _aux sendResp = http2Server req (`sendResp` [])

src/Simplex/Messaging/Transport/KeepAlive.hs

@@ -1,10 +1,15 @@
 {-# LANGUAGE CApiFFI #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Transport.KeepAlive where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
 import Foreign.C (CInt (..))
+import GHC.Generics (Generic)
 import Network.Socket
 
 data KeepAliveOpts = KeepAliveOpts
@@ -12,7 +17,9 @@ data KeepAliveOpts = KeepAliveOpts
     keepIntvl :: Int,
     keepCnt :: Int
   }
-  deriving (Show)
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON KeepAliveOpts where toEncoding = J.genericToEncoding J.defaultOptions
 
 defaultKeepAliveOpts :: KeepAliveOpts
 defaultKeepAliveOpts =

src/Simplex/Messaging/Transport/Server.hs

@@ -35,12 +35,12 @@ import UnliftIO.STM
 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --
 -- All accepted connections are passed to the passed function.
-runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()
-runTransportServer started port serverParams server = do
+runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> (c -> m ()) -> m ()
+runTransportServer started port serverParams logTLSErrors server = do
   u <- askUnliftIO
   liftIO . runTCPServer started port $ \conn ->
     E.bracket
-      (connectTLS serverParams conn >>= getServerConnection)
+      (connectTLS Nothing logTLSErrors serverParams conn >>= getServerConnection)
       closeConnection
       (unliftIO u . server)
 

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -18,6 +18,7 @@ import Simplex.Messaging.Transport
     TransportError (..),
     TransportPeer (..),
     closeTLS,
+    smpBlockSize,
     trimCR,
     withTlsUnique,
   )
@@ -33,7 +34,7 @@ websocketsOpts :: ConnectionOptions
 websocketsOpts =
   defaultConnectionOptions
     { connectionCompressionOptions = NoCompression,
-      connectionFramePayloadSizeLimit = SizeLimit $ 16 * 1024, -- TODO move to Protocol
+      connectionFramePayloadSizeLimit = SizeLimit $ fromIntegral smpBlockSize,
       connectionMessageDataSizeLimit = SizeLimit 65536
     }
 

src/Simplex/Messaging/Util.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -13,6 +12,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8With)
 import UnliftIO.Async
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -93,3 +93,8 @@ catchAll_ a = catchAll a . const
 eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
+
+safeDecodeUtf8 :: ByteString -> Text
+safeDecodeUtf8 = decodeUtf8With onError
+  where
+    onError _ _ = Just '?'

src/Simplex/Messaging/Version.hs

@@ -15,6 +15,7 @@ module Simplex.Messaging.Version
     pattern Compatible,
     mkVersionRange,
     safeVersionRange,
+    versionToRange,
     isCompatible,
     proveCompatible,
     compatibleVersion,
@@ -53,6 +54,9 @@ safeVersionRange v1 v2
   | v1 <= v2 = Just $ VRange v1 v2
   | otherwise = Nothing
 
+versionToRange :: Version -> VersionRange
+versionToRange v = VRange v v
+
 instance Encoding VersionRange where
   smpEncode (VRange v1 v2) = smpEncode (v1, v2)
   smpP =

stack.yaml

@@ -48,6 +48,12 @@ extra-deps:
   - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
   - github: simplex-chat/aeson
     commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7
+  # - ../direct-sqlcipher
+  - github: simplex-chat/direct-sqlcipher
+    commit: 34309410eb2069b029b8fc1872deb1e0db123294
+  # - ../sqlcipher-simple
+  - github: simplex-chat/sqlcipher-simple
+    commit: 5e154a2aeccc33ead6c243ec07195ab673137221
   # - ../hs-tls/core
   # - github: simplex-chat/hs-tls
   #   commit: f6cc753611f80af300401cfae63846e9d7c40d9e

tests/AgentTests.hs

@@ -22,6 +22,7 @@ import qualified Data.ByteString.Char8 as B
 import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
 import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
+import Simplex.Messaging.Agent.Env.SQLite (AgentDatabase, databaseFile)
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Encoding.String
@@ -77,10 +78,20 @@ agentTests (ATransport t) = do
       smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
     it "should deliver messages if one of connections has quota exceeded" $
       smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
+    it "should resume delivering messages after exceeding quota once all messages are received" $
+      smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
+
+tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+tGetAgent h = do
+  t@(_, _, cmd) <- tGet SAgent h
+  case cmd of
+    Right CONNECT {} -> tGetAgent h
+    Right DISCONNECT {} -> tGetAgent h
+    _ -> pure t
 
 -- | receive message to handle `h`
 (<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
-(<#:) = tGet SAgent
+(<#:) = tGetAgent
 
 -- | send transmission `t` to handle `h` and get response
 (#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
@@ -114,7 +125,7 @@ h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
 h #:# err = tryGet `shouldReturn` ()
   where
     tryGet =
-      10000 `timeout` tGet SAgent h >>= \case
+      10000 `timeout` tGetAgent h >>= \case
         Just _ -> error err
         _ -> return ()
 
@@ -123,10 +134,10 @@ pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnection _ alice bob = do
-  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")
+  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
   alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   bob <# ("", "alice", INFO "alice's connInfo")
   bob <# ("", "alice", CON)
@@ -156,10 +167,10 @@ testDuplexConnection _ alice bob = do
 
 testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnRandomIds _ alice bob = do
-  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")
+  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV")
   let cReq' = strEncode cReq
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
-  ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo")
+  ("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
   bobConn' `shouldBe` bobConn
   alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
   bob <# ("", aliceConn, INFO "alice's connInfo")
@@ -189,13 +200,13 @@ testDuplexConnRandomIds _ alice bob = do
 
 testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()
 testContactConnection _ alice bob tom = do
-  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")
+  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON")
   let cReq' = strEncode cReq
 
-  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
   alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-  ("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
+  ("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
   bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
   alice <# ("", "bob", INFO "bob's connInfo 2")
   alice <# ("", "bob", CON)
@@ -205,10 +216,10 @@ testContactConnection _ alice bob tom = do
   bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
   bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
 
-  tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
+  tom #: ("21", "alice", "JOIN T " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:)
   alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
-  ("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)
+  ("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:)
   tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
   alice <# ("", "tom", INFO "tom's connInfo 2")
   alice <# ("", "tom", CON)
@@ -220,15 +231,15 @@ testContactConnection _ alice bob tom = do
 
 testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testContactConnRandomIds _ alice bob = do
-  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")
+  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON")
   let cReq' = strEncode cReq
 
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
-  ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo")
+  ("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
   aliceContact' `shouldBe` aliceContact
 
   ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
-  ("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
+  ("", aliceConn', Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
   aliceConn' `shouldBe` aliceConn
 
   bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
@@ -243,10 +254,10 @@ testContactConnRandomIds _ alice bob = do
 
 testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
 testRejectContactRequest _ alice bob = do
-  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")
+  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
-  ("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
+  ("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:)
   -- RJCT must use correct contact connection
   alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
   alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
@@ -274,7 +285,7 @@ testSubscription _ alice1 alice2 bob = do
 
 testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
 testSubscrNotification t (server, _) client = do
-  client #: ("1", "conn1", "NEW INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
+  client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
   client <# ("", "", DOWN testSMPServer ["conn1"])
@@ -322,8 +333,8 @@ testServerConnectionAfterError t _ = do
 
   withAgent1 $ \bob -> do
     withAgent2 $ \alice -> do
-      bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
-      alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
+      bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
+      alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
       withServer $ do
         alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
         alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
@@ -335,14 +346,14 @@ testServerConnectionAfterError t _ = do
         bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
 
   removeFile testStoreLogFile
-  removeFile testDB
-  removeFile testDB2
+  removeFile $ databaseFile testDB
+  removeFile $ databaseFile testDB2
   where
     server = SMPServer "localhost" testPort2 testKeyHash
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent1 = withAgent agentTestPort testDB
     withAgent2 = withAgent agentTestPort2 testDB2
-    withAgent :: String -> String -> (c -> IO a) -> IO a
+    withAgent :: String -> AgentDatabase -> (c -> IO a) -> IO a
     withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
 
 testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
@@ -375,7 +386,7 @@ testMsgDeliveryAgentRestart t bob = do
       bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
-  removeFile testDB
+  removeFile $ databaseFile testDB
   where
     withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
     withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (pure ()) . const . testSMPAgentClientOn agentTestPort
@@ -384,10 +395,10 @@ testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
 testConcurrentMsgDelivery _ alice bob = do
   connect (alice, "alice") (bob, "bob")
 
-  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW INV")
+  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
-  ("", "bob2", Right (CONF _confId "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice2", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
+  ("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:)
   -- below commands would be needed to accept bob's connection, but alice does not
   -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   -- bob <# ("", "alice", INFO "alice's connInfo")
@@ -421,12 +432,38 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
   -- if delivery is blocked it won't go further
   alice <# ("", "bob2", SENT 4)
 
+testResumeDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
+testResumeDeliveryQuotaExceeded _ alice bob = do
+  connect (alice, "alice") (bob, "bob")
+  forM_ [1 .. 4 :: Int] $ \i -> do
+    let corrId = bshow i
+        msg = "message " <> bshow i
+    (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
+    alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
+  ("5", "bob", Right (MID 8)) <- alice #: ("5", "bob", "SEND F :over quota")
+  alice #:# "the last message not sent yet"
+  bob <#= \case ("", "alice", Msg "message 1") -> True; _ -> False
+  bob #: ("1", "alice", "ACK 4") #> ("1", "alice", OK)
+  alice #:# "the last message not sent"
+  bob <#= \case ("", "alice", Msg "message 2") -> True; _ -> False
+  bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
+  alice #:# "the last message not sent"
+  bob <#= \case ("", "alice", Msg "message 3") -> True; _ -> False
+  bob #: ("3", "alice", "ACK 6") #> ("3", "alice", OK)
+  alice #:# "the last message not sent"
+  bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False
+  bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK)
+  alice <# ("", "bob", SENT 8)
+  bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False
+  -- message 8 is skipped because of alice agent sending "QCONT" message
+  bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
+
 connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
 connect (h1, name1) (h2, name2) = do
-  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
+  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV")
   let cReq' = strEncode cReq
-  h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
-  ("", _, Right (CONF connId "info2")) <- (h1 <#:)
+  h2 #: ("c2", name1, "JOIN T " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
+  ("", _, Right (CONF connId _ "info2")) <- (h1 <#:)
   h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
   h2 <# ("", name1, INFO "info1")
   h2 <# ("", name1, CON)
@@ -444,10 +481,10 @@ sendMessage (h1, name1) (h2, name2) msg = do
 
 -- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
 -- connect' h1 h2 = do
---   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")
+--   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV")
 --   let cReq' = strEncode cReq
---   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
---   ("", _, Right (REQ connId "info2")) <- (h1 <#:)
+--   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " 5\ninfo2")
+--   ("", _, Right (REQ connId _ "info2")) <- (h1 <#:)
 --   h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
 --   h2 <# ("", conn1, INFO "info1")
 --   h2 <# ("", conn1, CON)
@@ -463,17 +500,17 @@ syntaxTests t = do
   describe "NEW" $ do
     describe "valid" $ do
       -- TODO: add tests with defined connection id
-      it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
+      it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
     describe "invalid" $ do
       -- TODO: add tests with defined connection id
-      it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
+      it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX")
 
   describe "JOIN" $ do
     describe "valid" $ do
       it "using same server as in invitation" $
         ( "311",
           "a",
-          "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
+          "JOIN T https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
             <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
             <> "%40localhost%3A5001%2F3456-w%3D%3D%23"
             <> urlEncode True sampleDhKey

tests/AgentTests/ConnectionRequestTests.hs

@@ -11,7 +11,7 @@ import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ProtocolServer (..), smpClientVRange)
+import Simplex.Messaging.Protocol (ProtocolServer (..), supportedSMPClientVRange)
 import Simplex.Messaging.Version
 import Test.Hspec
 
@@ -21,15 +21,23 @@ uri = "smp.simplex.im"
 srv :: SMPServer
 srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
 
-queue :: SMPQueueUri
-queue =
-  SMPQueueUri
+queueAddr :: SMPQueueAddress
+queueAddr =
+  SMPQueueAddress
     { smpServer = srv,
       senderId = "\223\142z\251",
-      clientVRange = smpClientVRange,
       dhPublicKey = testDhKey
     }
 
+queueAddrNoPort :: SMPQueueAddress
+queueAddrNoPort = queueAddr {smpServer = srv {port = ""}}
+
+queue :: SMPQueueUri
+queue = SMPQueueUri supportedSMPClientVRange queueAddr
+
+queueV1 :: SMPQueueUri
+queueV1 = SMPQueueUri (mkVersionRange 1 1) queueAddr
+
 testDhKey :: C.PublicKeyX25519
 testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
 
@@ -44,17 +52,18 @@ connReqData =
   ConnReqUriData
     { crScheme = simplexChat,
       crAgentVRange = mkVersionRange 1 1,
-      crSmpQueues = [queue]
+      crSmpQueues = [queueV1],
+      crClientData = Nothing
     }
 
 testDhPubKey :: C.PublicKeyX448
 testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U="
 
 testE2ERatchetParams :: E2ERatchetParamsUri 'C.X448
-testE2ERatchetParams = E2ERatchetParamsUri e2eEncryptVRange testDhPubKey testDhPubKey
+testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange 1 1) testDhPubKey testDhPubKey
 
-testE2ERatchetParams13 :: E2ERatchetParamsUri 'C.X448
-testE2ERatchetParams13 = E2ERatchetParamsUri (mkVersionRange 1 3) testDhPubKey testDhPubKey
+testE2ERatchetParams12 :: E2ERatchetParamsUri 'C.X448
+testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey
 
 connectionRequest :: AConnectionRequestUri
 connectionRequest =
@@ -65,41 +74,61 @@ connectionRequest12 :: AConnectionRequestUri
 connectionRequest12 =
   ACR SCMInvitation $
     CRInvitationUri
-      connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queue, queue]}
-      testE2ERatchetParams13
+      connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
+      testE2ERatchetParams12
+
+connectionRequestClientDataEmpty :: AConnectionRequestUri
+connectionRequestClientDataEmpty =
+  ACR SCMInvitation $
+    CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams
+
+connectionRequestClientData :: AConnectionRequestUri
+connectionRequestClientData =
+  ACR SCMInvitation $
+    CRInvitationUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} testE2ERatchetParams
 
 connectionRequestTests :: Spec
 connectionRequestTests =
   describe "connection request parsing / serializing" $ do
     it "should serialize SMP queue URIs" $ do
-      strEncode (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
-        `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr
+      strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
+        `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
       strEncode queue {clientVRange = mkVersionRange 1 2}
-        `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr
+        `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
     it "should parse SMP queue URIs" $ do
-      strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> testDhKeyStr)
-        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
+      strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStr)
+        `shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
       strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr)
-        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
+        `shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort}
       strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr)
-        `shouldBe` Right queue
-      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
-        `shouldBe` Right queue
-      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1-2&dh=" <> testDhKeyStr)
-        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
+        `shouldBe` Right queueV1
       strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")
-        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
+        `shouldBe` Right queue
+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr)
+        `shouldBe` Right queueV1
+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
+        `shouldBe` Right queueV1
     it "should serialize connection requests" $ do
       strEncode connectionRequest
-        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
-        <> testDhKeyStrUri
+        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        <> urlEncode True testDhKeyStrUri
         <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
       strEncode connectionRequest12
-        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
-        <> testDhKeyStrUri
-        <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
-        <> testDhKeyStrUri
-        <> "&e2e=v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        <> urlEncode True testDhKeyStrUri
+        <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        <> urlEncode True testDhKeyStrUri
+        <> "&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+      strEncode connectionRequestClientDataEmpty
+        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        <> urlEncode True testDhKeyStrUri
+        <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+        <> "&data=%7B%7D"
+      strEncode connectionRequestClientData
+        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        <> urlEncode True testDhKeyStrUri
+        <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+        <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
     it "should parse connection requests" $ do
       strDecode
         ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
@@ -127,8 +156,24 @@ connectionRequestTests =
             <> testDhKeyStrUri
             <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
             <> testDhKeyStrUri
-            <> "&e2e=extra_key%3Dnew%26v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&e2e=extra_key%3Dnew%26v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
             <> "&some_new_param=abc"
             <> "&v=1-2"
         )
         `shouldBe` Right connectionRequest12
+      strDecode
+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+            <> testDhKeyStrUri
+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&data=%7B%7D"
+            <> "&v=1-1"
+        )
+        `shouldBe` Right connectionRequestClientDataEmpty
+      strDecode
+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+            <> testDhKeyStrUri
+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
+            <> "&v=1-1"
+        )
+        `shouldBe` Right connectionRequestClientData

tests/AgentTests/DoubleRatchetTests.hs

@@ -46,6 +46,9 @@ doubleRatchetTests = do
     it "should agree the same ratchet parameters" $ do
       testX3dh C.SX25519
       testX3dh C.SX448
+    it "should agree the same ratchet parameters with version 1" $ do
+      testX3dhV1 C.SX25519
+      testX3dhV1 C.SX448
 
 paddedMsgLen :: Int
 paddedMsgLen = 100
@@ -56,7 +59,7 @@ fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen
 testMessageHeader :: Expectation
 testMessageHeader = do
   (k, _) <- C.generateKeyPair' @X25519
-  let hdr = MsgHeader {msgMaxVersion = e2eEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}
+  let hdr = MsgHeader {msgMaxVersion = currentE2EEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}
   parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr
 
 pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString)
@@ -168,8 +171,16 @@ testEncodeDecode x = do
 
 testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dh _ = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a e2eEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a e2eEncryptVersion
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a currentE2EEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a currentE2EEncryptVersion
+  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
+      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
+  paramsAlice `shouldBe` paramsBob
+
+testX3dhV1 :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testX3dhV1 _ = do
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a 1
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a 1
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   paramsAlice `shouldBe` paramsBob
@@ -189,13 +200,13 @@ withRatchets test = do
 
 initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)
 initRatchets = do
-  (pkBob1, pkBob2, e2eBob) <- generateE2EParams e2eEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams e2eEncryptVersion
+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams currentE2EEncryptVersion
+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams currentE2EEncryptVersion
   let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
       paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
   (_, pkBob3) <- C.generateKeyPair'
-  let bob = initSndRatchet (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet pkAlice2 paramsAlice
+  let bob = initSndRatchet supportedE2EEncryptVRange (C.publicKey pkAlice2) pkBob3 paramsBob
+      alice = initRcvRatchet supportedE2EEncryptVRange pkAlice2 paramsAlice
   pure (alice, bob)
 
 encrypt_ :: AlgorithmI a => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))

tests/AgentTests/FunctionalAPITests.hs

@@ -3,13 +3,18 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.FunctionalAPITests
   ( functionalAPITests,
+    testServerMatrix2,
     makeConnection,
+    exchangeGreetingsMsgId,
+    switchComplete,
     get,
     (##>),
     (=##>),
@@ -19,23 +24,29 @@ where
 
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad
-import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
 import Control.Monad.IO.Unlift
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import qualified Data.Map as M
+import Data.Maybe (isNothing)
 import qualified Data.Set as S
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import SMPAgentClient
-import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
+import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
+import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Client (ProtocolClientConfig (..))
-import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
+import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (ATransport (..))
+import Simplex.Messaging.Util (tryError)
 import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO
@@ -47,39 +58,38 @@ a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
 a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
 
 get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
-get c = atomically (readTBQueue $ subQ c)
+get c = do
+  t@(_, _, cmd) <- atomically (readTBQueue $ subQ c)
+  case cmd of
+    CONNECT {} -> get c
+    DISCONNECT {} -> get c
+    _ -> pure t
 
 pattern Msg :: MsgBody -> ACommand 'Agent
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 smpCfgV1 :: ProtocolClientConfig
-smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = mkVersionRange 1 1}
+smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = vr11}
 
 agentCfgV1 :: AgentConfig
-agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
+agentCfgV1 = agentCfg {smpAgentVRange = vr11, smpClientVRange = vr11, e2eEncryptVRange = vr11, smpCfg = smpCfgV1}
+
+agentCfgRatchetV1 :: AgentConfig
+agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11}
+
+vr11 :: VersionRange
+vr11 = mkVersionRange 1 1
 
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
   describe "Establishing duplex connection" $
-    it "should connect via one server using SMP agent clients" $
-      withSmpServer t testAgentClient
-  describe "Duplex connection between agent versions 1 and 2" $ do
-    it "should connect agent v1 to v1" $
-      withSmpServer t testAgentClientV1toV1
-    it "should connect agent v1 to v2" $
-      withSmpServer t testAgentClientV1toV2
-    it "should connect agent v2 to v1" $
-      withSmpServer t testAgentClientV2toV1
+    testMatrix2 t runAgentClientTest
+  describe "Establishing duplex connection v2, different Ratchet versions" $
+    testRatchetMatrix2 t runAgentClientTest
   describe "Establish duplex connection via contact address" $
-    it "should connect via one server using SMP agent clients" $
-      withSmpServer t testAgentClientContact
-  describe "Duplex connection via contact address between agent versions 1 and 2" $ do
-    it "should connect agent v1 to v1" $
-      withSmpServer t testAgentClientContactV1toV1
-    it "should connect agent v1 to v2" $
-      withSmpServer t testAgentClientContactV1toV2
-    it "should connect agent v2 to v1" $
-      withSmpServer t testAgentClientContactV2toV1
+    testMatrix2 t runAgentClientContactTest
+  describe "Establish duplex connection via contact address v2, different Ratchet versions" $
+    testRatchetMatrix2 t runAgentClientContactTest
   describe "Establishing connection asynchronously" $ do
     it "should connect with initiating client going offline" $
       withSmpServer t testAsyncInitiatingOffline
@@ -109,61 +119,108 @@ functionalAPITests t = do
   describe "Batching SMP commands" $ do
     it "should subscribe to multiple subscriptions with batching" $
       testBatchedSubscriptions t
+  describe "Async agent commands" $ do
+    it "should connect using async agent commands" $
+      withSmpServer t testAsyncCommands
+    it "should restore and complete async commands on restart" $
+      testAsyncCommandsRestore t
+    it "should accept connection using async command" $
+      withSmpServer t testAcceptContactAsync
+  describe "Queue rotation" $ do
+    describe "should switch delivery to the new queue" $
+      testServerMatrix2 t testSwitchConnection
+    describe "should switch to new queue asynchronously" $
+      testServerMatrix2 t testSwitchAsync
+    describe "should delete connection during rotation" $
+      testServerMatrix2 t testSwitchDelete
+  describe "SMP basic auth" $ do
+    describe "with server auth" $ do
+      --                                       allow NEW | server auth, v | clnt1 auth, v  | clnt2 auth, v    |  2 - success, 1 - JOIN fail, 0 - NEW fail
+      it "success                " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 2
+      it "disabled               " $ testBasicAuth t False (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 0
+      it "NEW fail, no auth      " $ testBasicAuth t True (Just "abcd", 5) (Nothing, 5) (Just "abcd", 5) `shouldReturn` 0
+      it "NEW fail, bad auth     " $ testBasicAuth t True (Just "abcd", 5) (Just "wrong", 5) (Just "abcd", 5) `shouldReturn` 0
+      it "NEW fail, version      " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 4) (Just "abcd", 5) `shouldReturn` 0
+      it "JOIN fail, no auth     " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 1
+      it "JOIN fail, bad auth    " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "wrong", 5) `shouldReturn` 1
+      it "JOIN fail, version     " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 4) `shouldReturn` 1
+    describe "no server auth" $ do
+      it "success     " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 2
+      it "srv disabled" $ testBasicAuth t False (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 0
+      it "version srv " $ testBasicAuth t True (Nothing, 4) (Nothing, 5) (Nothing, 5) `shouldReturn` 2
+      it "version fst " $ testBasicAuth t True (Nothing, 5) (Nothing, 4) (Nothing, 5) `shouldReturn` 2
+      it "version snd " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 4) `shouldReturn` 2
+      it "version both" $ testBasicAuth t True (Nothing, 5) (Nothing, 4) (Nothing, 4) `shouldReturn` 2
+      it "version all " $ testBasicAuth t True (Nothing, 4) (Nothing, 4) (Nothing, 4) `shouldReturn` 2
+      it "auth fst    " $ testBasicAuth t True (Nothing, 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 2
+      it "auth fst 2  " $ testBasicAuth t True (Nothing, 4) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 2
+      it "auth snd    " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Just "abcd", 5) `shouldReturn` 2
+      it "auth both   " $ testBasicAuth t True (Nothing, 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 2
+      it "auth, disabled" $ testBasicAuth t False (Nothing, 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 0
+  describe "SMP server test via agent API" $ do
+    it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
+    let srv1 = testSMPServer2 {keyHash = "1234"}
+    it "should fail with incorrect fingerprint" $ do
+      testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (SMPTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+    describe "server with password" $ do
+      let auth = Just "abcd"
+          srv = ProtoServerWithAuth testSMPServer2
+          authErr = Just (SMPTestFailure TSCreateQueue $ SMP AUTH)
+      it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing
+      it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr
+      it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr
+  describe "getRatchetAdHash" $
+    it "should return the same data for both peers" $
+      withSmpServer t testRatchetAdHash
 
-testAgentClient :: IO ()
-testAgentClient = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-  runAgentClientTest alice bob 3
+testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
+testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do
+  let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = mkVersionRange 4 srvVersion}
+      canCreate1 = canCreateQueue allowNewQueues srv clnt1
+      canCreate2 = canCreateQueue allowNewQueues srv clnt2
+      expected
+        | canCreate1 && canCreate2 = 2
+        | canCreate1 = 1
+        | otherwise = 0
+  created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth clnt1 clnt2
+  created `shouldBe` expected
+  pure created
 
-testAgentClientV1toV1 :: IO ()
-testAgentClientV1toV1 = do
-  alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
-  runAgentClientTest alice bob 4
+canCreateQueue :: Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> Bool
+canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
+  allowNew && (isNothing srvAuth || (srvVersion == 5 && clntVersion == 5 && srvAuth == clntAuth))
 
-testAgentClientV1toV2 :: IO ()
-testAgentClientV1toV2 = do
-  alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-  runAgentClientTest alice bob 4
+testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testMatrix2 t runTest = do
+  it "v2" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
+  it "v1" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfgV1 4 runTest
+  it "v1 to v2" $ withSmpServer t $ runTestCfg2 agentCfgV1 agentCfg 4 runTest
+  it "v2 to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgV1 4 runTest
 
-testAgentClientV2toV1 :: IO ()
-testAgentClientV2toV1 = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
-  runAgentClientTest alice bob 4
+testRatchetMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testRatchetMatrix2 t runTest = do
+  it "ratchet v2" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest
+  it "ratchet v1" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfgRatchetV1 3 runTest
+  it "ratchets v1 to v2" $ withSmpServer t $ runTestCfg2 agentCfgRatchetV1 agentCfg 3 runTest
+  it "ratchets v2 to v1" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetV1 3 runTest
 
-testAgentClientContact :: IO ()
-testAgentClientContact = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-  runAgentClientContactTest alice bob 3
+testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
+testServerMatrix2 t runTest = do
+  it "1 server" $ withSmpServer t $ runTest initAgentServers
+  it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
 
-testAgentClientContactV1toV1 :: IO ()
-testAgentClientContactV1toV1 = do
-  alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
-  runAgentClientContactTest alice bob 4
-
-testAgentClientContactV1toV2 :: IO ()
-testAgentClientContactV1toV2 = do
-  alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
-  runAgentClientContactTest alice bob 4
-
-testAgentClientContactV2toV1 :: IO ()
-testAgentClientContactV2toV1 = do
-  alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
-  runAgentClientContactTest alice bob 4
+runTestCfg2 :: AgentConfig -> AgentConfig -> AgentMsgId -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
+runTestCfg2 aliceCfg bobCfg baseMsgId runTest = do
+  alice <- getSMPAgentClient aliceCfg initAgentServers
+  bob <- getSMPAgentClient bobCfg {database = testDB2} initAgentServers
+  runTest alice bob baseMsgId
 
 runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientTest alice bob baseId = do
   Right () <- runExceptT $ do
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -197,11 +254,11 @@ runAgentClientTest alice bob baseId = do
 runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientContactTest alice bob baseId = do
   Right () <- runExceptT $ do
-    (_, qInfo) <- createConnection alice SCMContact
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, REQ invId "bob's connInfo") <- get alice
-    bobId <- acceptContact alice invId "alice's connInfo"
-    ("", _, CONF confId "alice's connInfo") <- get bob
+    (_, qInfo) <- createConnection alice True SCMContact Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, REQ invId _ "bob's connInfo") <- get alice
+    bobId <- acceptContact alice True invId "alice's connInfo"
+    ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
     get alice ##> ("", bobId, INFO "bob's connInfo")
     get alice ##> ("", bobId, CON)
@@ -243,14 +300,14 @@ noMessages c err = tryGet `shouldReturn` ()
 testAsyncInitiatingOffline :: IO ()
 testAsyncInitiatingOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    (bobId, cReq) <- createConnection alice SCMInvitation
+    (bobId, cReq) <- createConnection alice True SCMInvitation Nothing
     disconnectAgentClient alice
-    aliceId <- joinConnection bob cReq "bob's connInfo"
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
-    ("", _, CONF confId "bob's connInfo") <- get alice'
+    ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
     get alice' ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -261,14 +318,14 @@ testAsyncInitiatingOffline = do
 testAsyncJoiningOfflineBeforeActivation :: IO ()
 testAsyncJoiningOfflineBeforeActivation = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
     disconnectAgentClient bob
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
     subscribeConnection bob' aliceId
     get alice ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -279,17 +336,17 @@ testAsyncJoiningOfflineBeforeActivation = do
 testAsyncBothOffline :: IO ()
 testAsyncBothOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    (bobId, cReq) <- createConnection alice SCMInvitation
+    (bobId, cReq) <- createConnection alice True SCMInvitation Nothing
     disconnectAgentClient alice
-    aliceId <- joinConnection bob cReq "bob's connInfo"
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
     disconnectAgentClient bob
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
-    ("", _, CONF confId "bob's connInfo") <- get alice'
+    ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
-    bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    bob' <- liftIO $ getSMPAgentClient agentCfg {database = testDB2} initAgentServers
     subscribeConnection bob' aliceId
     get alice' ##> ("", bobId, CON)
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -300,12 +357,12 @@ testAsyncBothOffline = do
 testAsyncServerOffline :: ATransport -> IO ()
 testAsyncServerOffline t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   -- create connection and shutdown the server
   Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
-    runExceptT $ createConnection alice SCMInvitation
+    runExceptT $ createConnection alice True SCMInvitation Nothing
   -- connection fails
-  Left (BROKER NETWORK) <- runExceptT $ joinConnection bob cReq "bob's connInfo"
+  Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob True cReq "bob's connInfo"
   ("", "", DOWN srv conns) <- get alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
@@ -315,8 +372,8 @@ testAsyncServerOffline t = do
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
-    aliceId <- joinConnection bob cReq "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -328,18 +385,18 @@ testAsyncHelloTimeout :: IO ()
 testAsyncHelloTimeout = do
   -- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
   alice <- getSMPAgentClient agentCfgV1 initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2, helloTimeout = 1} initAgentServers
   Right () <- runExceptT $ do
-    (_, cReq) <- createConnection alice SCMInvitation
+    (_, cReq) <- createConnection alice True SCMInvitation Nothing
     disconnectAgentClient alice
-    aliceId <- joinConnection bob cReq "bob's connInfo"
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
   pure ()
 
 testDuplicateMessage :: ATransport -> IO ()
 testDuplicateMessage t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     Right (aliceId, bobId) <- runExceptT $ makeConnection alice bob
     Right () <- runExceptT $ do
@@ -349,7 +406,7 @@ testDuplicateMessage t = do
     disconnectAgentClient bob
 
     -- if the agent user did not send ACK, the message will be delivered again
-    bob1 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+    bob1 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
     Right () <- runExceptT $ do
       subscribeConnection bob1 aliceId
       get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
@@ -365,13 +422,13 @@ testDuplicateMessage t = do
   -- commenting two lines below and uncommenting further two lines would also pass,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
-  Left (BROKER TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
+  Left (BROKER _ TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
 
   disconnectAgentClient alice
   disconnectAgentClient bob1
 
   alice2 <- getSMPAgentClient agentCfg initAgentServers
-  bob2 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob2 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
 
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     Right () <- runExceptT $ do
@@ -387,9 +444,9 @@ testDuplicateMessage t = do
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection alice bob = do
-  (bobId, qInfo) <- createConnection alice SCMInvitation
-  aliceId <- joinConnection bob qInfo "bob's connInfo"
-  ("", _, CONF confId "bob's connInfo") <- get alice
+  (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+  aliceId <- joinConnection bob True qInfo "bob's connInfo"
+  ("", _, CONF confId _ "bob's connInfo") <- get alice
   allowConnection alice bobId confId "alice's connInfo"
   get alice ##> ("", bobId, CON)
   get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -402,7 +459,7 @@ testInactiveClientDisconnected t = do
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient agentCfg initAgentServers
     Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice SCMInvitation
+      (connId, _cReq) <- createConnection alice True SCMInvitation Nothing
       get alice ##> ("", "", DOWN testSMPServer [connId])
     pure ()
 
@@ -413,13 +470,13 @@ testActiveClientNotDisconnected t = do
     alice <- getSMPAgentClient agentCfg initAgentServers
     ts <- getSystemTime
     Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice SCMInvitation
+      (connId, _cReq) <- createConnection alice True SCMInvitation Nothing
       keepSubscribing alice connId ts
     pure ()
   where
     keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO ()
     keepSubscribing alice connId ts = do
-      ts' <- liftIO $ getSystemTime
+      ts' <- liftIO getSystemTime
       if milliseconds ts' - milliseconds ts < 2200
         then do
           -- keep sending SUB for 2.2 seconds
@@ -437,7 +494,7 @@ testActiveClientNotDisconnected t = do
 testSuspendingAgent :: IO ()
 testSuspendingAgent = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
@@ -456,7 +513,7 @@ testSuspendingAgent = do
 testSuspendingAgentCompleteSending :: ATransport -> IO ()
 testSuspendingAgentCompleteSending t = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
@@ -479,7 +536,9 @@ testSuspendingAgentCompleteSending t = do
     get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
     ("", "", SUSPENDED) <- get b
 
-    ("", "", UP {}) <- get a
+    r <- get a
+    liftIO $ print r
+    ("", "", UP {}) <- pure r
     get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
     ackMessage a bId 5
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
@@ -490,7 +549,7 @@ testSuspendingAgentCompleteSending t = do
 testSuspendingAgentTimeout :: ATransport -> IO ()
 testSuspendingAgentTimeout t = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right (aId, _) <- withSmpServer t . runExceptT $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
@@ -513,7 +572,7 @@ testSuspendingAgentTimeout t = do
 testBatchedSubscriptions :: ATransport -> IO ()
 testBatchedSubscriptions t = do
   a <- getSMPAgentClient agentCfg initAgentServers2
-  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers2
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers2
   Right conns <- runServers $ do
     conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
     forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
@@ -555,6 +614,240 @@ testBatchedSubscriptions t = do
         killThread t1
         pure res
 
+testAsyncCommands :: IO ()
+testAsyncCommands = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    bobId <- createConnectionAsync alice "1" True SCMInvitation
+    ("1", bobId', INV (ACR _ qInfo)) <- get alice
+    liftIO $ bobId' `shouldBe` bobId
+    aliceId <- joinConnectionAsync bob "2" True qInfo "bob's connInfo"
+    ("2", aliceId', OK) <- get bob
+    liftIO $ aliceId' `shouldBe` aliceId
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    allowConnectionAsync alice "3" bobId confId "alice's connInfo"
+    ("3", _, OK) <- get alice
+    get alice ##> ("", bobId, CON)
+    get bob ##> ("", aliceId, INFO "alice's connInfo")
+    get bob ##> ("", aliceId, CON)
+    -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
+    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
+    get alice ##> ("", bobId, SENT $ baseId + 1)
+    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
+    get alice ##> ("", bobId, SENT $ baseId + 2)
+    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+    ackMessageAsync bob "4" aliceId $ baseId + 1
+    ("4", _, OK) <- get bob
+    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
+    ackMessageAsync bob "5" aliceId $ baseId + 2
+    ("5", _, OK) <- get bob
+    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
+    get bob ##> ("", aliceId, SENT $ baseId + 3)
+    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
+    get bob ##> ("", aliceId, SENT $ baseId + 4)
+    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
+    ackMessageAsync alice "6" bobId $ baseId + 3
+    ("6", _, OK) <- get alice
+    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
+    ackMessageAsync alice "7" bobId $ baseId + 4
+    ("7", _, OK) <- get alice
+    deleteConnectionAsync alice "8" bobId
+    ("8", _, OK) <- get alice
+    liftIO $ noMessages alice "nothing else should be delivered to alice"
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+testAsyncCommandsRestore :: ATransport -> IO ()
+testAsyncCommandsRestore t = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  Right bobId <- runExceptT $ createConnectionAsync alice "1" True SCMInvitation
+  liftIO $ noMessages alice "alice doesn't receive INV because server is down"
+  disconnectAgentClient alice
+  alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+  withSmpServerStoreLogOn t testPort $ \_ -> do
+    Right () <- runExceptT $ do
+      subscribeConnection alice' bobId
+      ("1", _, INV _) <- get alice'
+      pure ()
+    pure ()
+
+testAcceptContactAsync :: IO ()
+testAcceptContactAsync = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    (_, qInfo) <- createConnection alice True SCMContact Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, REQ invId _ "bob's connInfo") <- get alice
+    bobId <- acceptContactAsync alice "1" True invId "alice's connInfo"
+    ("1", bobId', OK) <- get alice
+    liftIO $ bobId' `shouldBe` bobId
+    ("", _, CONF confId _ "alice's connInfo") <- get bob
+    allowConnection bob aliceId confId "bob's connInfo"
+    get alice ##> ("", bobId, INFO "bob's connInfo")
+    get alice ##> ("", bobId, CON)
+    get bob ##> ("", aliceId, CON)
+    -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
+    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
+    get alice ##> ("", bobId, SENT $ baseId + 1)
+    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
+    get alice ##> ("", bobId, SENT $ baseId + 2)
+    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+    ackMessage bob aliceId $ baseId + 1
+    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
+    ackMessage bob aliceId $ baseId + 2
+    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
+    get bob ##> ("", aliceId, SENT $ baseId + 3)
+    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
+    get bob ##> ("", aliceId, SENT $ baseId + 4)
+    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 3
+    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
+    ackMessage alice bobId $ baseId + 4
+    suspendConnection alice bobId
+    5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
+    get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
+    deleteConnection alice bobId
+    liftIO $ noMessages alice "nothing else should be delivered to alice"
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+testSwitchConnection :: InitialAgentServers -> IO ()
+testSwitchConnection servers = do
+  a <- getSMPAgentClient agentCfg servers
+  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
+  Right () <- runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    switchConnectionAsync a "" bId
+    switchComplete a bId b aId
+    exchangeGreetingsMsgId 10 a bId b aId
+  pure ()
+
+switchComplete :: AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()
+switchComplete a bId b aId = do
+  phase a bId QDRcv SPStarted
+  phase b aId QDSnd SPStarted
+  phase a bId QDRcv SPConfirmed
+  phase b aId QDSnd SPConfirmed
+  phase b aId QDSnd SPCompleted
+  phase a bId QDRcv SPCompleted
+
+phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> ExceptT AgentErrorType IO ()
+phase c connId d p =
+  get c >>= \(_, connId', msg) -> do
+    liftIO $ connId `shouldBe` connId'
+    case msg of
+      SWITCH d' p' _ -> liftIO $ do
+        d `shouldBe` d'
+        p `shouldBe` p'
+      ERR (AGENT A_DUPLICATE) -> phase c connId d p
+      r -> do
+        liftIO . putStrLn $ "expected: " <> show p <> ", received: " <> show r
+        SWITCH _ _ _ <- pure r
+        pure ()
+
+testSwitchAsync :: InitialAgentServers -> IO ()
+testSwitchAsync servers = do
+  Right (aId, bId) <- withA $ \a -> withB $ \b -> runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    pure (aId, bId)
+  let withA' = session withA bId
+      withB' = session withB aId
+  withA' $ \a -> do
+    switchConnectionAsync a "" bId
+    phase a bId QDRcv SPStarted
+  withB' $ \b -> phase b aId QDSnd SPStarted
+  withA' $ \a -> phase a bId QDRcv SPConfirmed
+  withB' $ \b -> do
+    phase b aId QDSnd SPConfirmed
+    phase b aId QDSnd SPCompleted
+  withA' $ \a -> phase a bId QDRcv SPCompleted
+  Right () <- withA $ \a -> withB $ \b -> runExceptT $ do
+    subscribeConnection a bId
+    subscribeConnection b aId
+    exchangeGreetingsMsgId 10 a bId b aId
+  pure ()
+  where
+    withAgent :: AgentConfig -> (AgentClient -> IO a) -> IO a
+    withAgent cfg' = bracket (getSMPAgentClient cfg' servers) disconnectAgentClient
+    session :: (forall a. (AgentClient -> IO a) -> IO a) -> ConnId -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
+    session withC connId a = do
+      Right () <- withC $ \c -> runExceptT $ do
+        subscribeConnection c connId
+        r <- a c
+        liftIO $ threadDelay 500000
+        pure r
+      pure ()
+    withA = withAgent agentCfg
+    withB = withAgent agentCfg {database = testDB2, initialClientId = 1}
+
+testSwitchDelete :: InitialAgentServers -> IO ()
+testSwitchDelete servers = do
+  a <- getSMPAgentClient agentCfg servers
+  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
+  Right () <- runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    disconnectAgentClient b
+    switchConnectionAsync a "" bId
+    phase a bId QDRcv SPStarted
+    deleteConnectionAsync a "1" bId
+    ("1", bId', OK) <- get a
+    liftIO $ bId `shouldBe` bId'
+  pure ()
+
+testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
+testCreateQueueAuth clnt1 clnt2 = do
+  a <- getClient clnt1
+  b <- getClient clnt2
+  Right created <- runExceptT $ do
+    tryError (createConnection a True SCMInvitation Nothing) >>= \case
+      Left (SMP AUTH) -> pure 0
+      Left e -> throwError e
+      Right (bId, qInfo) ->
+        tryError (joinConnection b True qInfo "bob's connInfo") >>= \case
+          Left (SMP AUTH) -> pure 1
+          Left e -> throwError e
+          Right aId -> do
+            ("", _, CONF confId _ "bob's connInfo") <- get a
+            allowConnection a bId confId "alice's connInfo"
+            get a ##> ("", bId, CON)
+            get b ##> ("", aId, INFO "alice's connInfo")
+            get b ##> ("", aId, CON)
+            exchangeGreetings a bId b aId
+            pure 2
+  pure created
+  where
+    getClient (clntAuth, clntVersion) =
+      let servers = initAgentServers {smp = [ProtoServerWithAuth testSMPServer clntAuth]}
+          smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion}
+       in getSMPAgentClient agentCfg {smpCfg} servers
+
+testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe SMPTestFailure)
+testSMPServerConnectionTest t newQueueBasicAuth srv =
+  withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do
+    a <- getSMPAgentClient agentCfg initAgentServers -- initially passed server is not running
+    Right r <- runExceptT $ testSMPServerConnection a srv
+    pure r
+
+testRatchetAdHash :: IO ()
+testRatchetAdHash = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    ad1 <- getConnectionRatchetAdHash a bId
+    ad2 <- getConnectionRatchetAdHash b aId
+    liftIO $ ad1 `shouldBe` ad2
+  pure ()
+
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings = exchangeGreetingsMsgId 4
 

tests/AgentTests/NotificationTests.hs

@@ -8,8 +8,7 @@
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-
-import AgentTests.FunctionalAPITests (get, makeConnection, (##>), (=##>), pattern Msg)
+import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
@@ -22,7 +21,7 @@ import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
 import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers, databaseFile)
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -44,7 +43,7 @@ removeFileIfExists filePath = do
 
 notificationTests :: ATransport -> Spec
 notificationTests t =
-  after_ (removeFile testDB >> removeFileIfExists testDB2) $ do
+  after_ (removeFile (databaseFile testDB) >> removeFileIfExists (databaseFile testDB2)) $ do
     describe "Managing notification tokens" $ do
       it "should register and verify notification token" $
         withAPNSMockServer $ \apns ->
@@ -84,6 +83,10 @@ notificationTests t =
       it "should resume subscriptions after SMP server is restarted" $ \_ ->
         withAPNSMockServer $ \apns ->
           withNtfServer t $ testNotificationsSMPRestart t apns
+    describe "should switch notifications to the new queue" $
+      testServerMatrix2 t $ \servers ->
+        withAPNSMockServer $ \apns ->
+          withNtfServer t $ testSwitchNotifications servers apns
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
@@ -142,7 +145,7 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
   a <- getSMPAgentClient agentCfg initAgentServers
-  a' <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  a' <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
@@ -207,12 +210,12 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right (bobId, aliceId, nonce, message) <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)
@@ -249,7 +252,8 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
     -- delete notification subscription
-    deleteNtfSub alice bobId
+    toggleConnectionNtfs alice bobId False
+    liftIO $ threadDelay 250000
     -- send message
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
@@ -263,42 +267,37 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
 testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
     -- alice registers notification token
-    _ <- registerTestToken alice "abcd" NMInstant apnsQ
+    DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
     -- bob registers notification token
-    _ <- registerTestToken bob "bcde" NMInstant apnsQ
+    DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ
     -- establish connection
     liftIO $ threadDelay 50000
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    liftIO $ threadDelay 500000
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    liftIO $ print 0
+    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    liftIO $ threadDelay 1000000
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    liftIO $ threadDelay 750000
     void $ messageNotification apnsQ
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     liftIO $ threadDelay 500000
     allowConnection alice bobId confId "alice's connInfo"
-    liftIO $ print 1
     void $ messageNotification apnsQ
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-    liftIO $ print 2
     void $ messageNotification apnsQ
     get alice ##> ("", bobId, CON)
-    liftIO $ print 3
     void $ messageNotification apnsQ
     get bob ##> ("", aliceId, CON)
     -- bob sends message
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    liftIO $ print 4
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
     -- alice sends message
     2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
     get alice ##> ("", bobId, SENT $ baseId + 2)
-    liftIO $ print 5
     void $ messageNotification apnsQ
     get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
     ackMessage bob aliceId $ baseId + 2
@@ -325,12 +324,12 @@ registerTestToken a token mode apnsQ = do
 testChangeNotificationsMode :: APNSMockServer -> IO ()
 testChangeNotificationsMode APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right () <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)
@@ -347,7 +346,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     -- set mode to NMPeriodic
     NTActive <- registerNtfToken alice tkn NMPeriodic
     -- send message, no notification
-    liftIO $ threadDelay 500000
+    liftIO $ threadDelay 750000
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     noNotification apnsQ
@@ -390,12 +389,12 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
 testChangeToken :: APNSMockServer -> IO ()
 testChangeToken APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right (aliceId, bobId) <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)
@@ -434,7 +433,7 @@ testChangeToken APNSMockServer {apnsQ} = do
 testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
 testNotificationsStoreLog t APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -461,7 +460,7 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   Right (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -489,9 +488,31 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     liftIO $ killThread threadId
   pure ()
 
+testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
+testSwitchNotifications servers APNSMockServer {apnsQ} = do
+  a <- getSMPAgentClient agentCfg servers
+  b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
+  Right () <- runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    _ <- registerTestToken a "abcd" NMInstant apnsQ
+    liftIO $ threadDelay 250000
+    let testMessage msg = do
+          msgId <- sendMessage b aId (SMP.MsgFlags True) msg
+          get b ##> ("", aId, SENT msgId)
+          void $ messageNotification apnsQ
+          get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
+          ackMessage a bId msgId
+    testMessage "hello"
+    switchConnectionAsync a "" bId
+    switchComplete a bId b aId
+    liftIO $ threadDelay 500000
+    testMessage "hello again"
+  pure ()
+
 messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apnsQ = do
-  1000000 `timeout` atomically (readTBQueue apnsQ) >>= \case
+  750000 `timeout` atomically (readTBQueue apnsQ) >>= \case
     Nothing -> error "no notification"
     Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
       nonce <- C.cbNonce <$> ntfData .-> "nonce"

tests/AgentTests/SQLiteTests.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -43,7 +44,7 @@ withStore2 = before connect2 . after (removeStore . fst)
     connect2 :: IO (SQLiteStore, SQLiteStore)
     connect2 = do
       s1 <- createStore
-      s2 <- connectSQLiteStore (dbFilePath s1)
+      s2 <- connectSQLiteStore (dbFilePath s1) ""
       pure (s1, s2)
 
 createStore :: IO SQLiteStore
@@ -51,7 +52,7 @@ createStore = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  createSQLiteStore (testDB <> show r) Migrations.app True
+  createSQLiteStore (testDB <> show r) "" Migrations.app True
 
 removeStore :: SQLiteStore -> IO ()
 removeStore db = do
@@ -114,7 +115,7 @@ testConcurrentWrites =
     runTest st connId = replicateM_ 100 . withTransaction st $ \db -> do
       (internalId, internalRcvId, _, _) <- updateRcvIds db connId
       let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
-      createRcvMsg db connId rcvMsgData
+      createRcvMsg db connId rcvQueue1 rcvMsgData
 
 testCompiledThreadsafe :: SpecWith SQLiteStore
 testCompiledThreadsafe =
@@ -139,7 +140,7 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {connId = "conn1", connAgentVersion = 1, duplexHandshake = Nothing}
+cData1 = ConnData {connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False}
 
 testPrivateSignKey :: C.APrivateSignKey
 testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -153,27 +154,37 @@ testDhSecret = "01234567890123456789012345678901"
 rcvQueue1 :: RcvQueue
 rcvQueue1 =
   RcvQueue
-    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+    { connId = "conn1",
+      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       rcvId = "1234",
       rcvPrivateKey = testPrivateSignKey,
       rcvDhSecret = testDhSecret,
       e2ePrivKey = testPrivDhKey,
       e2eDhSecret = Nothing,
-      sndId = Just "2345",
+      sndId = "2345",
       status = New,
+      dbQueueId = 1,
+      primary = True,
+      dbReplaceQueueId = Nothing,
+      smpClientVersion = 1,
       clientNtfCreds = Nothing
     }
 
 sndQueue1 :: SndQueue
 sndQueue1 =
   SndQueue
-    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+    { connId = "conn1",
+      server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       sndId = "3456",
       sndPublicKey = Nothing,
       sndPrivateKey = testPrivateSignKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
-      status = New
+      status = New,
+      dbQueueId = 1,
+      primary = True,
+      dbReplaceQueueId = Nothing,
+      smpClientVersion = 1
     }
 
 testCreateRcvConn :: SpecWith SQLiteStore
@@ -185,21 +196,23 @@ testCreateRcvConn =
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
     upgradeRcvConnToDuplex db "conn1" sndQueue1
-      `shouldReturn` Right ()
+      `shouldReturn` Right 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
 
 testCreateRcvConnRandomId :: SpecWith SQLiteStore
 testCreateRcvConnRandomId =
   it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
     Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
+    let rq' = (rcvQueue1 :: RcvQueue) {connId}
+        sq' = (sndQueue1 :: SndQueue) {connId}
     getConn db connId
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1))
+      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rq'))
     upgradeRcvConnToDuplex db connId sndQueue1
-      `shouldReturn` Right ()
+      `shouldReturn` Right 1
     getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq'] [sq']))
 
 testCreateRcvConnDuplicate :: SpecWith SQLiteStore
 testCreateRcvConnDuplicate =
@@ -207,7 +220,7 @@ testCreateRcvConnDuplicate =
     g <- newTVarIO =<< drgNew
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     createRcvConn db g cData1 rcvQueue1 SCMInvitation
-      `shouldReturn` Left (SEConnDuplicate)
+      `shouldReturn` Left SEConnDuplicate
 
 testCreateSndConn :: SpecWith SQLiteStore
 testCreateSndConn =
@@ -218,21 +231,23 @@ testCreateSndConn =
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
     upgradeSndConnToDuplex db "conn1" rcvQueue1
-      `shouldReturn` Right ()
+      `shouldReturn` Right 1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
 
 testCreateSndConnRandomID :: SpecWith SQLiteStore
 testCreateSndConnRandomID =
   it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do
     g <- newTVarIO =<< drgNew
     Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1
+    let rq' = (rcvQueue1 :: RcvQueue) {connId}
+        sq' = (sndQueue1 :: SndQueue) {connId}
     getConn db connId
-      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sndQueue1))
+      `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sq'))
     upgradeSndConnToDuplex db connId rcvQueue1
-      `shouldReturn` Right ()
+      `shouldReturn` Right 1
     getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq'] [sq']))
 
 testCreateSndConnDuplicate :: SpecWith SQLiteStore
 testCreateSndConnDuplicate =
@@ -240,7 +255,7 @@ testCreateSndConnDuplicate =
     g <- newTVarIO =<< drgNew
     _ <- createSndConn db g cData1 sndQueue1
     createSndConn db g cData1 sndQueue1
-      `shouldReturn` Left (SEConnDuplicate)
+      `shouldReturn` Left SEConnDuplicate
 
 testGetRcvConn :: SpecWith SQLiteStore
 testGetRcvConn =
@@ -250,7 +265,7 @@ testGetRcvConn =
     g <- newTVarIO =<< drgNew
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getRcvConn db smpServer recipientId
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+      `shouldReturn` Right (rcvQueue1, SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
 
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
@@ -263,7 +278,7 @@ testDeleteRcvConn =
       `shouldReturn` ()
     -- TODO check queues are deleted as well
     getConn db "conn1"
-      `shouldReturn` Left (SEConnNotFound)
+      `shouldReturn` Left SEConnNotFound
 
 testDeleteSndConn :: SpecWith SQLiteStore
 testDeleteSndConn =
@@ -276,7 +291,7 @@ testDeleteSndConn =
       `shouldReturn` ()
     -- TODO check queues are deleted as well
     getConn db "conn1"
-      `shouldReturn` Left (SEConnNotFound)
+      `shouldReturn` Left SEConnNotFound
 
 testDeleteDuplexConn :: SpecWith SQLiteStore
 testDeleteDuplexConn =
@@ -285,12 +300,12 @@ testDeleteDuplexConn =
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
     deleteConn db "conn1"
       `shouldReturn` ()
     -- TODO check queues are deleted as well
     getConn db "conn1"
-      `shouldReturn` Left (SEConnNotFound)
+      `shouldReturn` Left SEConnNotFound
 
 testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
 testUpgradeRcvConnToDuplex =
@@ -299,13 +314,18 @@ testUpgradeRcvConnToDuplex =
     _ <- createSndConn db g cData1 sndQueue1
     let anotherSndQueue =
           SndQueue
-            { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+            { connId = "conn1",
+              server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               sndId = "2345",
               sndPublicKey = Nothing,
               sndPrivateKey = testPrivateSignKey,
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
-              status = New
+              status = New,
+              dbQueueId = 1,
+              primary = True,
+              dbReplaceQueueId = Nothing,
+              smpClientVersion = 1
             }
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
       `shouldReturn` Left (SEBadConnType CSnd)
@@ -320,14 +340,19 @@ testUpgradeSndConnToDuplex =
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let anotherRcvQueue =
           RcvQueue
-            { server = SMPServer "smp.simplex.im" "5223" testKeyHash,
+            { connId = "conn1",
+              server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               rcvId = "3456",
               rcvPrivateKey = testPrivateSignKey,
               rcvDhSecret = testDhSecret,
               e2ePrivKey = testPrivDhKey,
               e2eDhSecret = Nothing,
-              sndId = Just "4567",
+              sndId = "4567",
               status = New,
+              dbQueueId = 1,
+              primary = True,
+              dbReplaceQueueId = Nothing,
+              smpClientVersion = 1,
               clientNtfCreds = Nothing
             }
     upgradeSndConnToDuplex db "conn1" anotherRcvQueue
@@ -367,15 +392,17 @@ testSetQueueStatusDuplex =
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1]))
     setRcvQueueStatus db rcvQueue1 Secured
       `shouldReturn` ()
+    let rq' = (rcvQueue1 :: RcvQueue) {status = Secured}
+        sq' = (sndQueue1 :: SndQueue) {status = Confirmed}
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sndQueue1]))
     setSndQueueStatus db sndQueue1 Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq'] [sq']))
 
 hw :: ByteString
 hw = encodeUtf8 "Hello world!"
@@ -401,12 +428,12 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
       externalPrevSndHash = "hash_from_sender"
     }
 
-testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation
-testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do
+testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvQueue -> RcvMsgData -> Expectation
+testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rq rcvMsgData@RcvMsgData {..} = do
   let MsgMeta {recipient = (internalId, _)} = msgMeta
   updateRcvIds db connId
     `shouldReturn` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
-  createRcvMsg db connId rcvMsgData
+  createRcvMsg db connId rq rcvMsgData
     `shouldReturn` ()
 
 testCreateRcvMsg :: SpecWith SQLiteStore
@@ -417,8 +444,8 @@ testCreateRcvMsg =
     _ <- withTransaction st $ \db -> do
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     withTransaction st $ \db -> do
-      testCreateRcvMsg_ db 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
-      testCreateRcvMsg_ db 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
+      testCreateRcvMsg_ db 0 "" connId rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
+      testCreateRcvMsg_ db 1 "hash_dummy" connId rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
 
 mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
 mkSndMsgData internalId internalSndId internalHash =
@@ -460,9 +487,9 @@ testCreateRcvAndSndMsgs =
       createRcvConn db g cData1 rcvQueue1 SCMInvitation
     withTransaction st $ \db -> do
       _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
-      testCreateRcvMsg_ db 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
-      testCreateRcvMsg_ db 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
+      testCreateRcvMsg_ db 0 "" connId rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
+      testCreateRcvMsg_ db 1 "rcv_hash_1" connId rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
       testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
-      testCreateRcvMsg_ db 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
+      testCreateRcvMsg_ db 2 "rcv_hash_2" connId rcvQueue1 $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
       testCreateSndMsg_ db "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
       testCreateSndMsg_ db "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"

tests/AgentTests/SchemaDump.hs

@@ -20,7 +20,7 @@ schemaDumpTest =
 
 testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
-  void $ createSQLiteStore testDB Migrations.app False
+  void $ createSQLiteStore testDB "" Migrations.app False
   void $ readCreateProcess (shell $ "touch " <> schema) ""
   savedSchema <- readFile schema
   savedSchema `seq` pure ()

tests/CLITests.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module CLITests where
+
+import Data.Ini (lookupValue, readIniFile)
+import Data.List (isPrefixOf)
+import Simplex.Messaging.Notifications.Server.Main
+import Simplex.Messaging.Server.Main
+import Simplex.Messaging.Transport (simplexMQVersion)
+import Simplex.Messaging.Util (catchAll_)
+import System.Directory (doesFileExist)
+import System.Environment (withArgs)
+import System.IO.Silently (capture_)
+import System.Timeout (timeout)
+import Test.Hspec
+import Test.Main (withStdin)
+
+cfgPath :: FilePath
+cfgPath = "tests/tmp/cli/etc/opt/simplex"
+
+logPath :: FilePath
+logPath = "tests/tmp/cli/etc/var/simplex"
+
+ntfCfgPath :: FilePath
+ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
+
+ntfLogPath :: FilePath
+ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications"
+
+cliTests :: Spec
+cliTests = do
+  describe "SMP server CLI" $ do
+    describe "initialize, start and delete the server" $ do
+      it "no store log, random password (default)" $ smpServerTest False True
+      it "with store log, random password (default)" $ smpServerTest True True
+      it "no store log, no password" $ smpServerTest False False
+      it "with store log, no password" $ smpServerTest True False
+  describe "Ntf server CLI" $ do
+    it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
+    it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
+
+smpServerTest :: Bool -> Bool -> IO ()
+smpServerTest storeLog basicAuth = do
+  capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
+    >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`))
+  Right ini <- readIniFile $ cfgPath <> "/smp-server.ini"
+  lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
+  lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
+  lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223"
+  lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
+  lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
+  lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "off"
+  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
+  r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
+  r `shouldContain` ["SMP server v" <> simplexMQVersion]
+  r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
+  r `shouldContain` ["Listening on port 5223 (TLS)..."]
+  r `shouldContain` ["not expiring inactive clients"]
+  r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"])
+  capture_ (withStdin "Y" . withArgs ["delete"] $ smpServerCLI cfgPath logPath)
+    >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
+  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
+
+ntfServerTest :: Bool -> IO ()
+ntfServerTest storeLog = do
+  capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
+    >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`))
+  Right ini <- readIniFile $ ntfCfgPath <> "/ntf-server.ini"
+  lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
+  lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
+  lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
+  lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
+  doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
+  r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
+  r `shouldContain` ["SMP notifications server v" <> ntfServerVersion]
+  r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
+  r `shouldContain` ["Listening on port 443 (TLS)..."]
+  capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
+    >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
+  doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False

tests/CoreTests/CryptoTests.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CoreTests.CryptoTests (cryptoTests) where
+
+import qualified Data.ByteString.Char8 as B
+import Data.Either (isRight)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Simplex.Messaging.Crypto as C
+import Test.Hspec
+import Test.Hspec.QuickCheck (modifyMaxSuccess)
+import Test.QuickCheck
+
+cryptoTests :: Spec
+cryptoTests = do
+  modifyMaxSuccess (const 10000) . describe "padding / unpadding" $ do
+    it "should pad / unpad string" . property $ \(s, paddedLen) ->
+      let b = encodeUtf8 $ T.pack s
+          len = B.length b
+          padded = C.pad b paddedLen
+       in if len < 2 ^ (16 :: Int) - 3 && len <= paddedLen - 2
+            then (padded >>= C.unPad) == Right b
+            else padded == Left C.CryptoLargeMsgError
+    it "pad should fail on large string" $ do
+      C.pad "abc" 5 `shouldBe` Right "\000\003abc"
+      C.pad "abc" 4 `shouldBe` Left C.CryptoLargeMsgError
+      let s = B.replicate 65533 'a'
+      (C.pad s 65535 >>= C.unPad) `shouldBe` Right s
+      C.pad (B.replicate 65534 'a') 65536 `shouldBe` Left C.CryptoLargeMsgError
+      C.pad (B.replicate 65535 'a') 65537 `shouldBe` Left C.CryptoLargeMsgError
+    it "unpad should fail on invalid string" $ do
+      C.unPad "\000\000" `shouldBe` Right ""
+      C.unPad "\000" `shouldBe` Left C.CryptoInvalidMsgError
+      C.unPad "" `shouldBe` Left C.CryptoInvalidMsgError
+    it "unpad should fail on shorter string" $ do
+      C.unPad "\000\003abc" `shouldBe` Right "abc"
+      C.unPad "\000\003ab" `shouldBe` Left C.CryptoInvalidMsgError
+  describe "Ed signatures" $ do
+    describe "Ed25519" $ testSignature C.SEd25519
+    describe "Ed448" $ testSignature C.SEd448
+  describe "DH X25519 + cryptobox" $
+    testDHCryptoBox
+  describe "X509 key encoding" $ do
+    describe "Ed25519" $ testEncoding C.SEd25519
+    describe "Ed448" $ testEncoding C.SEd448
+    describe "X25519" $ testEncoding C.SX25519
+    describe "X448" $ testEncoding C.SX448
+
+testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec
+testSignature alg = it "should sign / verify string" . ioProperty $ do
+  (k, pk) <- C.generateSignatureKeyPair alg
+  pure $ \s -> let b = encodeUtf8 $ T.pack s in C.verify k (C.sign pk b) b
+
+testDHCryptoBox :: Spec
+testDHCryptoBox = it "should encrypt / decrypt string" . ioProperty $ do
+  (sk, spk) <- C.generateKeyPair'
+  (rk, rpk) <- C.generateKeyPair'
+  nonce <- C.randomCbNonce
+  pure $ \(s, pad) ->
+    let b = encodeUtf8 $ T.pack s
+        paddedLen = B.length b + abs pad + 2
+        cipher = C.cbEncrypt (C.dh' rk spk) nonce b paddedLen
+        plain = C.cbDecrypt (C.dh' sk rpk) nonce =<< cipher
+     in isRight cipher && cipher /= plain && Right b == plain
+
+testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec
+testEncoding alg = it "should encode / decode key" . ioProperty $ do
+  (k, pk) <- C.generateKeyPair alg
+  pure $ \(_ :: Int) ->
+    C.decodePubKey (C.encodePubKey k) == Right k
+      && C.decodePrivKey (C.encodePrivKey pk) == Right pk

tests/CoreTests/ProtocolErrorTests.hs

@@ -1,9 +1,14 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module CoreTests.ProtocolErrorTests where
 
-import Simplex.Messaging.Agent.Protocol (AgentErrorType)
-import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (ErrorType)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (parseAll)
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
@@ -11,9 +16,13 @@ import Test.QuickCheck
 protocolErrorTests :: Spec
 protocolErrorTests = modifyMaxSuccess (const 1000) $ do
   describe "errors parsing / serializing" $ do
-    it "should parse SMP protocol errors" . property $ \err ->
-      parseAll strP (strEncode err)
-        == Right (err :: ErrorType)
-    it "should parse SMP agent errors" . property $ \err ->
-      parseAll strP (strEncode err)
-        == Right (err :: AgentErrorType)
+    it "should parse SMP protocol errors" . property $ \(err :: AgentErrorType) ->
+      errServerHasSpaces err
+        || parseAll strP (strEncode err) == Right err
+    it "should parse SMP agent errors" . property $ \(err :: AgentErrorType) ->
+      errServerHasSpaces err
+        || parseAll strP (strEncode err) == Right err
+  where
+    errServerHasSpaces = \case
+      BROKER srv _ -> ' ' `B.elem` encodeUtf8 (T.pack srv)
+      _ -> False

tests/CoreTests/RetryIntervalTests.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CoreTests.RetryIntervalTests where
+
+import Control.Concurrent.STM
+import Control.Monad (when)
+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
+import Simplex.Messaging.Agent.RetryInterval
+import Test.Hspec
+
+retryIntervalTests :: Spec
+retryIntervalTests = do
+  describe "Retry interval with 2 modes and lock" $ do
+    testRetryIntervalSameMode
+    testRetryIntervalSwitchMode
+
+testRI :: RetryInterval2
+testRI =
+  RetryInterval2
+    { riSlow =
+        RetryInterval
+          { initialInterval = 20000,
+            increaseAfter = 40000,
+            maxInterval = 40000
+          },
+      riFast =
+        RetryInterval
+          { initialInterval = 10000,
+            increaseAfter = 20000,
+            maxInterval = 40000
+          }
+    }
+
+testRetryIntervalSameMode :: Spec
+testRetryIntervalSameMode =
+  it "should increase elapased time and interval when the mode stays the same" $ do
+    lock <- newEmptyTMVarIO
+    intervals <- newTVarIO []
+    ts <- newTVarIO =<< getCurrentTime
+    withRetryLock2 testRI lock $ \loop -> do
+      ints <- addInterval intervals ts
+      when (length ints < 9) $ loop RIFast
+    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4, 4]
+
+testRetryIntervalSwitchMode :: Spec
+testRetryIntervalSwitchMode =
+  it "should increase elapased time and interval when the mode stays the same" $ do
+    lock <- newEmptyTMVarIO
+    intervals <- newTVarIO []
+    ts <- newTVarIO =<< getCurrentTime
+    withRetryLock2 testRI lock $ \loop -> do
+      ints <- addInterval intervals ts
+      when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow
+    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 2, 2, 3, 4, 4]
+
+addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
+addInterval intervals ts = do
+  ts' <- getCurrentTime
+  atomically $ do
+    int :: Int <- truncate . (* 100) . nominalDiffTimeToSeconds <$> stateTVar ts (\t -> (diffUTCTime ts' t, ts'))
+    stateTVar intervals $ \ints -> (int : ints, int : ints)

tests/NtfClient.hs

@@ -18,18 +18,19 @@ module NtfClient where
 import Control.Monad
 import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift
-import Crypto.Random
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
+import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -43,7 +44,6 @@ import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.HTTP2 (http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.KeepAlive
 import Test.Hspec
 import UnliftIO.Async
 import UnliftIO.Concurrent
@@ -51,7 +51,7 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 import UnliftIO.Timeout (timeout)
 
-testHost :: HostName
+testHost :: NonEmpty TransportHost
 testHost = "localhost"
 
 ntfTestPort :: ServiceName
@@ -66,9 +66,10 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 ntfTestStoreLogFile :: FilePath
 ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 
-testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
-testNtfClient client =
-  runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
+testNtfClient client = do
+  Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
+  runTransportClient defaultTransportClientConfig host ntfTestPort (Just testKeyHash) $ \h ->
     liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -94,16 +95,22 @@ ntfServerCfg =
       -- CA certificate private key is not needed for initialization
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt"
+      certificateFile = "tests/fixtures/server.crt",
+      -- stats config
+      logStatsInterval = Nothing,
+      logStatsStartTime = 0,
+      serverStatsLogFile = "tests/ntf-server-stats.daily.log",
+      serverStatsBackupFile = Nothing,
+      logTLSErrors = True
     }
 
-withNtfServerStoreLog :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ThreadId -> m a) -> m a
+withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
 withNtfServerStoreLog t = withNtfServerCfg t ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile}
 
-withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withNtfServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
 withNtfServerThreadOn t port' = withNtfServerCfg t ntfServerCfg {transports = [(port', t)]}
 
-withNtfServerCfg :: (MonadUnliftIO m, MonadRandom m) => ATransport -> NtfServerConfig -> (ThreadId -> m a) -> m a
+withNtfServerCfg :: ATransport -> NtfServerConfig -> (ThreadId -> IO a) -> IO a
 withNtfServerCfg t cfg =
   serverBracket
     (\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]})
@@ -122,13 +129,13 @@ serverBracket process afterProcess f = do
         Nothing -> error $ "server did not " <> s
         _ -> pure ()
 
-withNtfServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
+withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a
 withNtfServerOn t port' = withNtfServerThreadOn t port' . const
 
-withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
+withNtfServer :: ATransport -> IO a -> IO a
 withNtfServer t = withNtfServerOn t ntfTestPort
 
-runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
+runNtfTest :: forall c a. Transport c => (THandle c -> IO a) -> IO a
 runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
 
 ntfServerTest ::
@@ -171,7 +178,8 @@ apnsMockServerConfig =
       serverSupported = http2TLSParams,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt"
+      certificateFile = "tests/fixtures/server.crt",
+      logTLSErrors = True
     }
 
 withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()

tests/NtfServerTests.hs

@@ -10,7 +10,6 @@
 module NtfServerTests where
 
 import Control.Concurrent (threadDelay)
-import Control.Monad.Except (runExceptT)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (first)
@@ -77,8 +76,7 @@ sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
 signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
 signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right sig <- runExceptT $ C.sign pk t
-  Right () <- tPut1 h (Just sig, t)
+  Right () <- tPut1 h (Just $ C.sign pk t, t)
   tGet1 h
 
 (.->) :: J.Value -> J.Key -> Either String ByteString

tests/SMPAgentClient.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -9,8 +10,9 @@ module SMPAgentClient where
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
-import Network.Socket (HostName, ServiceName)
+import Network.Socket (ServiceName)
 import NtfClient (ntfTestPort)
 import SMPClient
   ( serverBracket,
@@ -25,15 +27,15 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
-import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
+import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.KeepAlive
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
 
-agentTestHost :: HostName
+agentTestHost :: NonEmpty TransportHost
 agentTestHost = "localhost"
 
 agentTestPort :: ServiceName
@@ -45,24 +47,31 @@ agentTestPort2 = "5011"
 agentTestPort3 :: ServiceName
 agentTestPort3 = "5012"
 
-testDB :: String
-testDB = "tests/tmp/smp-agent.test.protocol.db"
+testDB :: AgentDatabase
+testDB = AgentDBFile {dbFile = "tests/tmp/smp-agent.test.protocol.db", dbKey = ""}
 
-testDB2 :: String
-testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
+testDB2 :: AgentDatabase
+testDB2 = AgentDBFile {dbFile = "tests/tmp/smp-agent2.test.protocol.db", dbKey = ""}
 
-testDB3 :: String
-testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
+testDB3 :: AgentDatabase
+testDB3 = AgentDBFile {dbFile = "tests/tmp/smp-agent3.test.protocol.db", dbKey = ""}
 
 smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
-smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> tGetRaw h
+smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
+  where
+    get h = do
+      t@(_, _, cmdStr) <- tGetRaw h
+      case parseAll networkCommandP cmdStr of
+        Right (ACmd SAgent CONNECT {}) -> get h
+        Right (ACmd SAgent DISCONNECT {}) -> get h
+        _ -> pure t
 
-runSmpAgentTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (c -> m a) -> m a
+runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a
 runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test
   where
     t = transport @c
 
-runSmpAgentServerTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> c -> m a) -> m a
+runSmpAgentServerTest :: forall c a. Transport c => ((ThreadId, ThreadId) -> c -> IO a) -> IO a
 runSmpAgentServerTest test =
   withSmpServerThreadOn t testPort $
     \server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $
@@ -73,23 +82,23 @@ runSmpAgentServerTest test =
 smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
 smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
 
-runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
+runSmpAgentTestN :: forall c a. Transport c => [(ServiceName, ServiceName, AgentDatabase)] -> ([c] -> IO a) -> IO a
 runSmpAgentTestN agents test = withSmpServer t $ run agents []
   where
-    run :: [(ServiceName, ServiceName, String)] -> [c] -> m a
+    run :: [(ServiceName, ServiceName, AgentDatabase)] -> [c] -> IO a
     run [] hs = test hs
     run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
     t = transport @c
 
-runSmpAgentTestN_1 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([c] -> m a) -> m a
+runSmpAgentTestN_1 :: forall c a. Transport c => Int -> ([c] -> IO a) -> IO a
 runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients []
   where
-    run :: Int -> [c] -> m a
+    run :: Int -> [c] -> IO a
     run 0 hs = test hs
     run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs)
     t = transport @c
 
-smpAgentTestN :: Transport c => [(ServiceName, ServiceName, String)] -> ([c] -> IO ()) -> Expectation
+smpAgentTestN :: Transport c => [(ServiceName, ServiceName, AgentDatabase)] -> ([c] -> IO ()) -> Expectation
 smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` ()
 
 smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation
@@ -164,24 +173,25 @@ testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5
 initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
-    { smp = L.fromList [testSMPServer],
-      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
+    { smp = L.fromList [noAuthSrv testSMPServer],
+      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
+      netCfg = defaultNetworkConfig {tcpTimeout = 500_000}
     }
 
 initAgentServers2 :: InitialAgentServers
-initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
+initAgentServers2 = initAgentServers {smp = L.fromList [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]}
 
 agentCfg :: AgentConfig
 agentCfg =
   defaultAgentConfig
     { tcpPort = agentTestPort,
-      tbqSize = 1,
-      dbFile = testDB,
+      tbqSize = 4,
+      database = testDB,
       smpCfg =
         defaultClientConfig
           { qSize = 1,
             defaultTransport = (testPort, transport @TLS),
-            tcpTimeout = 500_000
+            networkConfig = defaultNetworkConfig {tcpTimeout = 500_000}
           },
       ntfCfg =
         defaultClientConfig
@@ -196,31 +206,32 @@ agentCfg =
       certificateFile = "tests/fixtures/server.crt"
     }
 
-withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> m () -> (ThreadId -> m a) -> m a
 withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
-  let cfg' = agentCfg {tcpPort = port', dbFile = db'}
-      initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
+  let cfg' = agentCfg {tcpPort = port', database = db'}
+      initServers' = initAgentServers {smp = L.fromList [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
    in serverBracket
         (\started -> runSMPAgentBlocking t started cfg' initServers')
         afterProcess
 
-withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile db'
+withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile (dbFile db')
 
-withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m a -> m a
+withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> m a -> m a
 withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const
 
 withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
 withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
-testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
+testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
+  Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost
+  runTransportClient defaultTransportClientConfig useHost port' (Just testKeyHash) $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
       then client h
       else do
         error $ "wrong welcome message: " <> B.unpack line
 
-testSMPAgentClient :: (Transport c, MonadUnliftIO m) => (c -> m a) -> m a
+testSMPAgentClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (c -> m a) -> m a
 testSMPAgentClient = testSMPAgentClientOn agentTestPort

tests/SMPClient.hs

@@ -12,9 +12,10 @@ module SMPClient where
 
 import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift
-import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.List.NonEmpty (NonEmpty)
 import Network.Socket
+import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
@@ -22,7 +23,6 @@ import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO.Concurrent
@@ -30,7 +30,7 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
 import UnliftIO.Timeout (timeout)
 
-testHost :: HostName
+testHost :: NonEmpty TransportHost
 testHost = "localhost"
 
 testPort :: ServiceName
@@ -54,9 +54,10 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 testServerStatsBackupFile :: FilePath
 testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 
-testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
-testSMPClient client =
-  runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
+testSMPClient client = do
+  Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
+  runTransportClient defaultTransportClientConfig useHost testPort (Just testKeyHash) $ \h ->
     liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -76,6 +77,7 @@ cfg =
       storeLogFile = Nothing,
       storeMsgsFile = Nothing,
       allowNewQueues = True,
+      newQueueBasicAuth = Nothing,
       messageExpiration = Just defaultMessageExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
@@ -85,25 +87,26 @@ cfg =
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
-      smpServerVRange = supportedSMPServerVRange
+      smpServerVRange = supportedSMPServerVRange,
+      logTLSErrors = True
     }
 
-withSmpServerStoreMsgLogOnV2 :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerStoreMsgLogOnV2 :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
 withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
 
-withSmpServerStoreMsgLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerStoreMsgLogOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
 withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
-withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerStoreLogOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
 withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
-withSmpServerConfigOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServerConfig -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerConfigOn :: ATransport -> ServerConfig -> ServiceName -> (ThreadId -> IO a) -> IO a
 withSmpServerConfigOn t cfg' port' =
   serverBracket
     (\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
     (pure ())
 
-withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
 withSmpServerThreadOn t = withSmpServerConfigOn t cfg
 
 serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
@@ -119,19 +122,19 @@ serverBracket process afterProcess f = do
         Nothing -> error $ "server did not " <> s
         _ -> pure ()
 
-withSmpServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
+withSmpServerOn :: ATransport -> ServiceName -> IO a -> IO a
 withSmpServerOn t port' = withSmpServerThreadOn t port' . const
 
-withSmpServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
+withSmpServer :: ATransport -> IO a -> IO a
 withSmpServer t = withSmpServerOn t testPort
 
-runSmpTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
+runSmpTest :: forall c a. Transport c => (THandle c -> IO a) -> IO a
 runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
 
-runSmpTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([THandle c] -> m a) -> m a
+runSmpTestN :: forall c a. Transport c => Int -> ([THandle c] -> IO a) -> IO a
 runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
   where
-    run :: Int -> [THandle c] -> m a
+    run :: Int -> [THandle c] -> IO a
     run 0 hs = test hs
     run n hs = testSMPClient $ \h -> run (n - 1) (h : hs)
 

tests/ServerTests.hs

@@ -14,7 +14,7 @@ module ServerTests where
 import Control.Concurrent (ThreadId, killThread, threadDelay)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, try)
-import Control.Monad.Except (forM, forM_, runExceptT)
+import Control.Monad.Except (forM, forM_)
 import Control.Monad.IO.Class
 import Data.Bifunctor (first)
 import Data.ByteString.Base64
@@ -49,9 +49,10 @@ serverTests t@(ATransport t') = do
     describe "switch subscription to another TCP connection" $ testSwitchSub t
     describe "GET command" $ testGetCommand t'
     describe "GET & SUB commands" $ testGetSubCommands t'
+    describe "Exceeding queue quota" $ testExceedQueueQuota t'
   describe "Store log" $ testWithStoreLog t
   describe "Restore messages" $ testRestoreMessages t
-  describe "Restore messages (v2)" $ testRestoreMessagesV2 t
+  describe "Restore messages (old / v2)" $ testRestoreMessagesV2 t
   describe "Timing of AUTH error" $ testTiming t
   describe "Message notifications" $ testMessageNotifications t
   describe "Message expiration" $ do
@@ -77,8 +78,7 @@ sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
 signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
 signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right sig <- runExceptT $ C.sign pk t
-  Right () <- tPut1 h (Just sig, t)
+  Right () <- tPut1 h (Just $ C.sign pk t, t)
   tGet1 h
 
 tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
@@ -104,9 +104,11 @@ decryptMsgV2 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either C.Cry
 decryptMsgV2 dhShared = C.cbDecrypt dhShared . C.cbNonce
 
 decryptMsgV3 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either String MsgBody
-decryptMsgV3 dhShared nonce body = do
-  ClientRcvMsgBody {msgBody} <- parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared (C.cbNonce nonce) body)
-  pure msgBody
+decryptMsgV3 dhShared nonce body =
+  case parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared (C.cbNonce nonce) body) of
+    Right ClientRcvMsgBody {msgBody} -> Right msgBody
+    Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota"
+    Left e -> Left e
 
 testCreateSecureV2 :: forall c. Transport c => TProxy c -> Spec
 testCreateSecureV2 _ =
@@ -114,7 +116,7 @@ testCreateSecureV2 _ =
     withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
       let dec = decryptMsgV2 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
 
@@ -146,8 +148,10 @@ testCreateSecureV2 _ =
       (ok2, OK) #== "secures queue"
       (rId2, rId) #== "same queue ID in response 3"
 
-      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
-      (err4, ERR AUTH) #== "rejects KEY if already secured"
+      Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub)
+      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
+      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub')
+      (err4, ERR AUTH) #== "rejects if secured with different key"
 
       Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
       (ok3, OK) #== "accepts signed SEND"
@@ -176,7 +180,7 @@ testCreateSecure (ATransport t) =
     smpTest t $ \h -> do
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
 
@@ -208,8 +212,10 @@ testCreateSecure (ATransport t) =
       (ok2, OK) #== "secures queue"
       (rId2, rId) #== "same queue ID in response 3"
 
-      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
-      (err4, ERR AUTH) #== "rejects KEY if already secured"
+      Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub)
+      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
+      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub')
+      (err4, ERR AUTH) #== "rejects if secured with different key"
 
       Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
       (ok3, OK) #== "accepts signed SEND"
@@ -238,7 +244,7 @@ testCreateDelete (ATransport t) =
     smpTest2 t $ \rh sh -> do
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       (rId1, "") #== "creates queue"
 
@@ -309,7 +315,7 @@ stressTest (ATransport t) =
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
       (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
       rIds <- forM ([1 .. 50] :: [Int]) . const $ do
-        Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)
+        Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing)
         pure rId
       let subscribeQueues h = forM_ rIds $ \rId -> do
             Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
@@ -326,7 +332,7 @@ testAllowNewQueues t =
       testSMPClient @c $ \h -> do
         (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
         (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
-        Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
+        Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
         pure ()
 
 testDuplex :: ATransport -> Spec
@@ -335,7 +341,7 @@ testDuplex (ATransport t) =
     smpTest2 t $ \alice bob -> do
       (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448
       (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub)
+      Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing)
       let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
       -- aSnd ID is passed to Bob out-of-band
 
@@ -351,7 +357,7 @@ testDuplex (ATransport t) =
 
       (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448
       (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub)
+      Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing)
       let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
       Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
       -- "reply_id ..." is ad-hoc, not a part of SMP protocol
@@ -389,7 +395,7 @@ testSwitchSub (ATransport t) =
     smpTest3 t $ \rh1 rh2 sh -> do
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub)
+      Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
       (ok1, OK) #== "sent test message 1"
@@ -490,6 +496,32 @@ testGetSubCommands t =
       Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET)
       pure ()
 
+testExceedQueueQuota :: forall c. Transport c => TProxy c -> Spec
+testExceedQueueQuota t =
+  it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ do
+    withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ ->
+      testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do
+        (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
+        (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
+        let dec = decryptMsgV3 dhShared
+        Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1")
+        Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello 2")
+        Resp "3" _ (ERR QUOTA) <- signSendRecv sh sKey ("3", sId, _SEND "hello 3")
+        Resp "" _ (Msg mId1 msg1) <- tGet1 rh
+        (dec mId1 msg1, Right "hello 1") #== "hello 1"
+        Resp "4" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("4", rId, ACK mId1)
+        (dec mId2 msg2, Right "hello 2") #== "hello 2"
+        Resp "5" _ (ERR QUOTA) <- signSendRecv sh sKey ("5", sId, _SEND "hello 3")
+        Resp "6" _ (Msg mId3 msg3) <- signSendRecv rh rKey ("6", rId, ACK mId2)
+        (dec mId3 msg3, Left "ClientRcvMsgQuota") #== "ClientRcvMsgQuota"
+        Resp "7" _ (ERR QUOTA) <- signSendRecv sh sKey ("7", sId, _SEND "hello 3")
+        Resp "8" _ OK <- signSendRecv rh rKey ("8", rId, ACK mId3)
+        Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND "hello 3")
+        Resp "" _ (Msg mId4 msg4) <- tGet1 rh
+        (dec mId4 msg4, Right "hello 3") #== "hello 3"
+        Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4)
+        pure ()
+
 testWithStoreLog :: ATransport -> Spec
 testWithStoreLog at@(ATransport t) =
   it "should store simplex queues to log and restore them after server restart" $ do
@@ -596,10 +628,12 @@ testRestoreMessages at@(ATransport t) =
       Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2")
       Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3")
       Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4")
+      Resp "5" _ OK <- signSendRecv h sKey ("5", sId, _SEND "hello 5")
+      Resp "6" _ (ERR QUOTA) <- signSendRecv h sKey ("6", sId, _SEND "hello 6")
       pure ()
 
     logSize testStoreLogFile `shouldReturn` 2
-    logSize testStoreMsgsFile `shouldReturn` 3
+    logSize testStoreMsgsFile `shouldReturn` 5
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       rId <- readTVarIO recipientId
@@ -615,15 +649,21 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 1
     -- the last message is not removed because it was not ACK'd
-    logSize testStoreMsgsFile `shouldReturn` 1
+    logSize testStoreMsgsFile `shouldReturn` 3
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       rId <- readTVarIO recipientId
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
+      let dec = decryptMsgV3 dh
       Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB)
-      Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK mId4)
-      (decryptMsgV3 dh mId4 msg4, Right "hello 4") #== "restored message delivered"
+      (dec mId4 msg4, Right "hello 4") #== "restored message delivered"
+      Resp "5" _ (Msg mId5 msg5) <- signSendRecv h rKey ("5", rId, ACK mId4)
+      (dec mId5 msg5, Right "hello 5") #== "restored message delivered"
+      Resp "6" _ (Msg mId6 msg6) <- signSendRecv h rKey ("6", rId, ACK mId5)
+      (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered"
+      Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6)
+      pure ()
 
     logSize testStoreLogFile `shouldReturn` 1
     logSize testStoreMsgsFile `shouldReturn` 0
@@ -712,7 +752,7 @@ createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (Se
 createAndSecureQueue h sPub = do
   (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
   (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-  Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
+  Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
   let dhShared = C.dh' srvDh dhPriv
   Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
   (rId', rId) #== "same queue ID"
@@ -737,7 +777,7 @@ testTiming (ATransport t) =
     testSameTiming rh sh (goodKeySize, badKeySize, n) = do
       (rPub, rKey) <- generateKeys goodKeySize
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
+      Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
 

tests/Test.hs

@@ -1,8 +1,12 @@
 {-# LANGUAGE TypeApplications #-}
 
 import AgentTests (agentTests)
+import CLITests
+import Control.Logger.Simple
+import CoreTests.CryptoTests
 import CoreTests.EncodingTests
 import CoreTests.ProtocolErrorTests
+import CoreTests.RetryIntervalTests
 import CoreTests.VersionRangeTests
 import NtfServerTests (ntfServerTests)
 import ServerTests
@@ -12,18 +16,26 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
 
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
 main :: IO ()
 main = do
-  createDirectoryIfMissing False "tests/tmp"
-  setEnv "APNS_KEY_ID" "H82WD9K9AQ"
-  setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
-  hspec $ do
-    describe "Core tests" $ do
-      describe "Encoding tests" encodingTests
-      describe "Protocol error tests" protocolErrorTests
-      describe "Version range" versionRangeTests
-    describe "SMP server via TLS" $ serverTests (transport @TLS)
-    describe "SMP server via WebSockets" $ serverTests (transport @WS)
-    describe "Notifications server" $ ntfServerTests (transport @TLS)
-    describe "SMP client agent" $ agentTests (transport @TLS)
-  removeDirectoryRecursive "tests/tmp"
+  setLogLevel LogError -- LogInfo
+  withGlobalLogging logCfg $ do
+    createDirectoryIfMissing False "tests/tmp"
+    setEnv "APNS_KEY_ID" "H82WD9K9AQ"
+    setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
+    hspec $ do
+      describe "Core tests" $ do
+        describe "Encoding tests" encodingTests
+        describe "Protocol error tests" protocolErrorTests
+        describe "Version range" versionRangeTests
+        describe "Encryption tests" cryptoTests
+        describe "Retry interval tests" retryIntervalTests
+      describe "SMP server via TLS" $ serverTests (transport @TLS)
+      describe "SMP server via WebSockets" $ serverTests (transport @WS)
+      describe "Notifications server" $ ntfServerTests (transport @TLS)
+      describe "SMP client agent" $ agentTests (transport @TLS)
+      describe "Server CLIs" cliTests
+    removeDirectoryRecursive "tests/tmp"