4.4.0 (#624)

* 4.4.0

* changelog

CHANGELOG.md

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

README.md

@@ -94,15 +94,97 @@ 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.
 
@@ -112,14 +194,6 @@ You can run your SMP server as a Linux process, optionally using a service manag
 
 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="Docker" src="./img/docker.svg" align="right" width="200">
-
-## Deploy SMP server with Docker
-
-SMP server could also be deployed using `Docker`.
-
-See: [`scripts/docker`](./scripts/docker/)
-
 [<img alt="Linode" src="./img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
 
 ## Deploy SMP server on Linode

apps/ntf-server/Main.hs

@@ -1,18 +1,7 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main where
 
 import Control.Logger.Simple
-import Data.Functor (($>))
-import Data.Ini (lookupValue)
-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"
@@ -26,63 +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.2.0",
-          mkIniFile = \enableStoreLog defaultServerPort ->
-            "[STORE_LOG]\n\
-            \# The server uses STM memory for persistence,\n\
-            \# that will be lost on restart (e.g., as with redis).\n\
-            \# This option enables saving memory to append only log,\n\
-            \# and restoring it when the server is started.\n\
-            \# Log is compacted on start (deleted objects are removed).\n\
-            \enable: "
-              <> (if enableStoreLog then "on" else "off")
-              <> "\n\
-                 \log_stats: off\n\n\
-                 \[TRANSPORT]\n\
-                 \port: "
-              <> defaultServerPort
-              <> "\n\
-                 \websockets: off\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 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,
-                    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"
-                  }
-        }
+  withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath

apps/smp-agent/Main.hs

@@ -7,6 +7,7 @@ module Main where
 
 import Control.Logger.Simple
 import qualified Data.List.NonEmpty as L
+import qualified Data.Map.Strict as M
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Server (runSMPAgent)
 import Simplex.Messaging.Client (defaultNetworkConfig)
@@ -18,7 +19,7 @@ cfg = defaultAgentConfig
 servers :: InitialAgentServers
 servers =
   InitialAgentServers
-    { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
+    { smp = M.fromList [(1, L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"])],
       ntf = [],
       netCfg = defaultNetworkConfig
     }

apps/smp-server/Main.hs

@@ -1,19 +1,7 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main where
 
 import Control.Logger.Simple
-import Data.Functor (($>))
-import Data.Ini (lookupValue)
-import Simplex.Messaging.Server (runSMPServer)
-import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
-import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
-import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
-import System.FilePath (combine)
+import Simplex.Messaging.Server.Main
 
 cfgPath :: FilePath
 cfgPath = "/etc/opt/simplex"
@@ -27,83 +15,4 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 main :: IO ()
 main = do
   setLogLevel LogDebug
-  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
-                  }
-        }
+  withGlobalLogging logCfg $ smpServerCLI cfgPath logPath

build.Dockerfile

@@ -11,17 +11,15 @@ RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghc
     chmod +x /usr/bin/ghcup
 
 # Install ghc
-RUN ghcup install ghc
+RUN ghcup install ghc 8.10.7
 # Install cabal
 RUN ghcup install cabal
 # Set both as default
-RUN ghcup set ghc && \
+RUN ghcup set ghc 8.10.7 && \
     ghcup set cabal
 
-# Clone simplexmq repository
-RUN git clone https://github.com/simplex-chat/simplexmq
-# and cd to it
-WORKDIR ./simplexmq
+COPY . /project
+WORKDIR /project
 
 # Adjust PATH
 ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
@@ -41,7 +39,7 @@ RUN apt-get update && apt-get install -y openssl
 COPY --from=build /root/.cabal/bin/smp-server /usr/bin/smp-server
 
 # Copy our helper script
-COPY ./entrypoint /usr/bin/entrypoint
+COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
 
 # Open smp-server listening port
 EXPOSE 5223

cabal.project

@@ -1,11 +1,17 @@
 packages: .
 -- packages: . ../direct-sqlcipher ../sqlcipher-simple
+-- packages: . ../hs-socks
 
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/aeson.git
     tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
 
+source-repository-package
+    type: git
+    location: https://github.com/simplex-chat/hs-socks.git
+    tag: a30cc7a79a08d8108316094f8f2f82a0c5e1ac51
+
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/direct-sqlcipher.git

download.Dockerfile

@@ -8,7 +8,7 @@ RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/s
 	chmod +x /usr/bin/smp-server
 
 # Copy our helper script
-COPY ./entrypoint /usr/bin/entrypoint
+COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
 
 # Open smp-server listening port
 EXPOSE 5223

package.yaml

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

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

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

rfcs/done/2022-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/README.md

@@ -1,25 +0,0 @@
-# smp-server docker container
-0. Install `docker` to your host.
-
-1. Build your `smp-server` image:
-    - **Option 1** - Compile `smp-server` from source (stable branch):
-    ```sh
-    DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-build.Dockerfile .
-    ```
-    - **Option 2** - Download latest `smp-server` from [latest Github release](https://github.com/simplex-chat/simplexmq/releases/latest):
-    ```sh
-    DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-download.Dockerfile .
-    ```
-
-2. Run new docker container:
-```sh
-docker run -d \
-	--name smp-server \
-	-e addr="your_ip_or_domain" \
-	-p 5223:5223 \
-	-v ${PWD}/config:/etc/opt/simplex \
-	-v ${PWD}/logs:/var/opt/simplex \
-	smp-server
-```
-
-Configuration files and logs will be written to [`config`](./config) and [`logs`](./logs) folders respectively.

scripts/docker/config/README.md

@@ -1 +0,0 @@
-smp-server configuration, certificate and fingerprint will be stored here

scripts/docker/entrypoint

@@ -4,13 +4,19 @@ 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]*) smp-server init -l -n "$addr" ;;
-		*) smp-server init -l --ip "$addr" ;;
-	esac
+  # 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

scripts/docker/logs/README.md

@@ -1 +0,0 @@
-smp-server general logs, stored messages and statistics (if enabled) will be stored here

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.3.1
+version:        4.4.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -55,6 +55,10 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
+      Simplex.Messaging.Agent.TAsyncs
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
@@ -66,6 +70,7 @@ 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
@@ -78,6 +83,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
@@ -150,9 +156,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
@@ -212,9 +218,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
@@ -274,9 +280,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
@@ -336,9 +342,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
@@ -351,9 +357,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
@@ -393,6 +401,7 @@ test-suite smp-server-test
     , http2 ==3.0.*
     , ini ==0.4.1
     , iso8601-time ==0.1.*
+    , main-tester ==0.2.*
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
@@ -400,6 +409,7 @@ test-suite smp-server-test
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , silently ==1.2.*
     , simple-logger ==0.1.*
     , simplexmq
     , socks ==0.6.*
@@ -419,6 +429,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

@@ -17,12 +17,14 @@
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
+    SMPTestFailure (..),
+    SMPTestStep (..),
     newAgentClient,
     withConnLock,
     closeAgentClient,
     closeProtocolServerClients,
+    runSMPServerTest,
     newRcvQueue,
-    subscribeQueue,
     subscribeQueues,
     getQueueMessage,
     decryptSMPMessage,
@@ -31,6 +33,7 @@ module Simplex.Messaging.Agent.Client
     sendConfirmation,
     sendInvitation,
     temporaryAgentError,
+    temporaryOrHostError,
     secureQueue,
     enableQueueNotifications,
     disableQueueNotifications,
@@ -50,6 +53,7 @@ module Simplex.Messaging.Agent.Client
     sendAck,
     suspendQueue,
     deleteQueue,
+    deleteQueues,
     logServer,
     logSecret,
     removeSubscription,
@@ -59,6 +63,7 @@ module Simplex.Messaging.Agent.Client
     AgentOpState (..),
     AgentState (..),
     AgentLocks (..),
+    AgentStatsKey (..),
     agentOperations,
     agentOperationBracket,
     waitUntilActive,
@@ -76,7 +81,8 @@ 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, throwSTM)
 import Control.Exception (AsyncException (..))
@@ -90,10 +96,10 @@ 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 (isRight, partitionEithers)
+import Data.Either (lefts, partitionEithers)
 import Data.Functor (($>))
-import Data.List (partition, (\\))
-import Data.List.NonEmpty (NonEmpty (..))
+import Data.List (foldl', 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
@@ -104,12 +110,14 @@ import Data.Text.Encoding
 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.TAsyncs
 import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues)
 import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import Simplex.Messaging.Client
@@ -120,10 +128,11 @@ 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.Parsers (dropPrefix, enumJSON, parse)
 import Simplex.Messaging.Protocol
   ( AProtocolType (..),
     BrokerMsg,
+    EntityId,
     ErrorType,
     MsgFlags (..),
     MsgId,
@@ -149,7 +158,7 @@ import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Timeout (timeout)
-import UnliftIO (async)
+import UnliftIO (mapConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -159,21 +168,25 @@ type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
 
 type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
 
+type SMPTransportSession = TransportSession SMP.BrokerMsg
+
+type NtfTransportSession = TransportSession NtfResponse
+
 data AgentClient = AgentClient
   { active :: TVar Bool,
     rcvQ :: TBQueue (ATransmission 'Client),
     subQ :: TBQueue (ATransmission 'Agent),
     msgQ :: TBQueue (ServerTransmission BrokerMsg),
-    smpServers :: TVar (NonEmpty SMPServer),
-    smpClients :: TMap SMPServer SMPClientVar,
+    smpServers :: TMap UserId (NonEmpty SMPServerWithAuth),
+    smpClients :: TMap SMPTransportSession SMPClientVar,
     ntfServers :: TVar [NtfServer],
-    ntfClients :: TMap NtfServer NtfClientVar,
+    ntfClients :: TMap NtfTransportSession NtfClientVar,
     useNetworkConfig :: TVar NetworkConfig,
     subscrConns :: TVar (Set ConnId),
     activeSubs :: TRcvQueues,
     pendingSubs :: TRcvQueues,
     pendingMsgsQueued :: TMap SndQAddr Bool,
-    smpQueueMsgQueues :: TMap SndQAddr (TQueue InternalId),
+    smpQueueMsgQueues :: TMap SndQAddr (TQueue InternalId, TMVar ()),
     smpQueueMsgDeliveries :: TMap SndQAddr (Async ()),
     connCmdsQueued :: TMap ConnId Bool,
     asyncCmdQueues :: TMap (Maybe SMPServer) (TQueue AsyncCmdId),
@@ -187,10 +200,13 @@ data AgentClient = AgentClient
     getMsgLocks :: TMap (SMPServer, SMP.RecipientId) (TMVar ()),
     -- locks to prevent concurrent operations with connection
     connLocks :: TMap ConnId Lock,
+    -- lock to prevent concurrency between periodic and async connection deletions
+    deleteLock :: Lock,
     -- locks to prevent concurrent reconnections to SMP servers
-    reconnectLocks :: TMap SMPServer Lock,
-    reconnections :: TVar [Async ()],
-    asyncClients :: TVar [Async ()],
+    reconnectLocks :: TMap SMPTransportSession Lock,
+    reconnections :: TAsyncs,
+    asyncClients :: TAsyncs,
+    agentStats :: TMap AgentStatsKey (TVar Int),
     clientId :: Int,
     agentEnv :: Env
   }
@@ -214,11 +230,20 @@ 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}
+data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map String String, delLock :: Maybe String}
   deriving (Show, Generic)
 
 instance ToJSON AgentLocks where toEncoding = J.genericToEncoding J.defaultOptions
 
+data AgentStatsKey = AgentStatsKey
+  { userId :: UserId,
+    host :: ByteString,
+    clientTs :: ByteString,
+    cmd :: ByteString,
+    res :: ByteString
+  }
+  deriving (Eq, Ord, Show)
+
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
 newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
@@ -248,17 +273,54 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   agentState <- newTVar ASActive
   getMsgLocks <- TM.empty
   connLocks <- TM.empty
+  deleteLock <- createLock
   reconnectLocks <- TM.empty
-  reconnections <- newTVar []
-  asyncClients <- newTVar []
+  reconnections <- newTAsyncs
+  asyncClients <- newTAsyncs
+  agentStats <- TM.empty
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
-  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, clientId, agentEnv}
+  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,
+        deleteLock,
+        reconnectLocks,
+        reconnections,
+        asyncClients,
+        agentStats,
+        clientId,
+        agentEnv
+      }
 
 agentClientStore :: AgentClient -> SQLiteStore
 agentClientStore AgentClient {agentEnv = Env {store}} = store
 
 class ProtocolServerClient msg where
-  getProtocolServerClient :: AgentMonad m => AgentClient -> ProtoServer msg -> m (ProtocolClient msg)
+  getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient msg)
   clientProtocolError :: ErrorType -> AgentErrorType
 
 instance ProtocolServerClient BrokerMsg where
@@ -269,19 +331,19 @@ instance ProtocolServerClient NtfResponse where
   getProtocolServerClient = getNtfServerClient
   clientProtocolError = NTF
 
-getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
-getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
+getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
+getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
-  atomically (getClientVar srv smpClients)
+  atomically (getClientVar tSess smpClients)
     >>= either
-      (newProtocolClient c srv smpClients connectClient reconnectClient)
-      (waitForProtocolClient c)
+      (newProtocolClient c tSess smpClients connectClient reconnectSMPClient)
+      (waitForProtocolClient c tSess)
   where
     connectClient :: m SMPClient
     connectClient = do
-      cfg <- atomically . updateClientConfig c =<< 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 tSess cfg (Just msgQ) $ clientDisconnected u)
 
     clientDisconnected :: UnliftIO m -> SMPClient -> IO ()
     clientDisconnected u client = do
@@ -290,135 +352,135 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
       where
         removeClientAndSubs :: IO ([RcvQueue], [ConnId])
         removeClientAndSubs = atomically $ do
-          TM.delete srv smpClients
-          qs <- RQ.getDelSrvQueues srv $ activeSubs c
+          TM.delete tSess smpClients
+          qs <- RQ.getDelSessQueues tSess $ activeSubs c
           mapM_ (`RQ.addQueue` pendingSubs c) qs
-          cs <- RQ.getConns (activeSubs c)
-          -- TODO deduplicate conns
-          let conns = map (connId :: RcvQueue -> ConnId) qs \\ S.toList cs
-          pure (qs, conns)
+          let cs = S.fromList $ map qConnId qs
+          cs' <- RQ.getConns $ activeSubs c
+          pure (qs, S.toList $ cs `S.difference` cs')
 
         serverDown :: ([RcvQueue], [ConnId]) -> IO ()
         serverDown (qs, conns) = whenM (readTVarIO active) $ do
+          incClientStat c userId 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
+            unliftIO u $ reconnectServer c tSess
 
-        reconnectServer :: m ()
-        reconnectServer = do
-          a <- async tryReconnectClient
-          atomically $ modifyTVar' (reconnections c) (a :)
+        notifySub :: ConnId -> ACommand 'Agent -> IO ()
+        notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
 
-        tryReconnectClient :: m ()
-        tryReconnectClient = do
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \loop ->
-            reconnectClient `catchError` const loop
-
-    reconnectClient :: m ()
-    reconnectClient =
-      withLockMap_ (reconnectLocks c) srv "reconnect" $
-        atomically (RQ.getSrvQueues srv $ pendingSubs c) >>= resubscribe
-      where
-        resubscribe :: [RcvQueue] -> m ()
-        resubscribe qs = do
-          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 $ mapM_ (notifySub "" . hostEvent CONNECT) client_
-            -- TODO deduplicate okConns
-            let conns = okConns \\ S.toList 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
+reconnectServer :: AgentMonad m => AgentClient -> SMPTransportSession -> m ()
+reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c
+  where
+    tryReconnectSMPClient aId = do
+      ri <- asks $ reconnectInterval . config
+      withRetryInterval ri $ \loop ->
+        reconnectSMPClient c tSess `catchError` const loop
+      atomically . removeAsyncAction aId $ reconnections c
 
+reconnectSMPClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m ()
+reconnectSMPClient c tSess@(_, srv, _) =
+  withLockMap_ (reconnectLocks c) tSess "reconnect" $
+    atomically (RQ.getSessQueues tSess $ pendingSubs c) >>= mapM_ resubscribe . L.nonEmpty
+  where
+    resubscribe :: NonEmpty RcvQueue -> m ()
+    resubscribe qs = do
+      cs <- atomically . RQ.getConns $ activeSubs c
+      rs <- subscribeQueues c $ L.toList qs
+      let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
+      liftIO $ do
+        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)
 
-getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfServer -> m NtfClient
-getNtfServerClient c@AgentClient {active, ntfClients} srv = do
+getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient
+getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
-  atomically (getClientVar srv ntfClients)
+  atomically (getClientVar tSess ntfClients)
     >>= either
-      (newProtocolClient c srv ntfClients connectClient $ pure ())
-      (waitForProtocolClient c)
+      (newProtocolClient c tSess ntfClients connectClient $ \_ _ -> pure ())
+      (waitForProtocolClient c tSess)
   where
     connectClient :: m NtfClient
     connectClient = do
-      cfg <- atomically . updateClientConfig c =<< asks (ntfCfg . config)
-      liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
+      cfg <- getClientConfig c ntfCfg
+      liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing clientDisconnected)
 
     clientDisconnected :: NtfClient -> IO ()
     clientDisconnected client = do
-      atomically $ TM.delete srv ntfClients
+      atomically $ TM.delete tSess ntfClients
+      incClientStat c userId 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))
-getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients
+getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
+getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup tSess clients
   where
     newClientVar :: STM (TMVar a)
     newClientVar = do
       var <- newEmptyTMVar
-      TM.insert srv var clients
+      TM.insert tSess var clients
       pure var
 
-waitForProtocolClient :: AgentMonad m => AgentClient -> ClientVar msg -> m (ProtocolClient msg)
-waitForProtocolClient c clientVar = do
+waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession 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, ProtocolTypeI (ProtoType msg)) =>
   AgentClient ->
-  ProtoServer msg ->
-  TMap (ProtoServer msg) (ClientVar msg) ->
+  TransportSession msg ->
+  TMap (TransportSession msg) (ClientVar msg) ->
   m (ProtocolClient msg) ->
-  m () ->
+  (AgentClient -> TransportSession msg -> m ()) ->
   ClientVar msg ->
   m (ProtocolClient msg)
-newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
+newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
   where
     tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a
     tryConnectClient successAction retryAction =
       tryError connectClient >>= \r -> case r of
         Right client -> do
-          logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
+          logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
           atomically $ putTMVar clientVar r
+          liftIO $ incClientStat c userId client "CLIENT" "OK"
           atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client)
           successAction client
         Left e -> do
+          liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
           if temporaryAgentError e
             then retryAction
             else atomically $ do
               putTMVar clientVar (Left e)
-              TM.delete srv clients
+              TM.delete tSess clients
           throwError e
     tryConnectAsync :: m ()
-    tryConnectAsync = do
-      a <- async connectAsync
-      atomically $ modifyTVar' (asyncClients c) (a :)
-    connectAsync :: m ()
-    connectAsync = do
+    tryConnectAsync = newAsyncAction connectAsync $ asyncClients c
+    connectAsync :: Int -> m ()
+    connectAsync aId = do
       ri <- asks $ reconnectInterval . config
-      withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
+      withRetryInterval ri $ \loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop
+      atomically . removeAsyncAction aId $ asyncClients c
 
 hostEvent :: forall msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent
-hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost client
+hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client
 
-updateClientConfig :: AgentClient -> ProtocolClientConfig -> STM ProtocolClientConfig
-updateClientConfig AgentClient {useNetworkConfig} cfg = do
-  networkConfig <- readTVar useNetworkConfig
+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 ()
@@ -426,8 +488,8 @@ closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
   closeProtocolServerClients c smpClients
   closeProtocolServerClients c ntfClients
-  cancelActions $ reconnections c
-  cancelActions $ asyncClients c
+  cancelActions . actions $ reconnections c
+  cancelActions . actions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
   cancelActions $ asyncCmdProcesses c
   atomically . RQ.clear $ activeSubs c
@@ -456,9 +518,9 @@ throwWhenNoDelivery c SndQueue {server, sndId} =
   where
     k = (server, sndId)
 
-closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO ()
+closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
-  readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+  atomically (swapTVar cs M.empty) >>= mapM_ (forkIO . closeClient)
   where
     cs = clientsSel c
     closeClient cVar = do
@@ -468,7 +530,7 @@ closeProtocolServerClients c clientsSel =
         _ -> pure ()
 
 cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
-cancelActions as = readTVarIO as >>= mapM_ (forkIO . uninterruptibleCancel) >> atomically (writeTVar as mempty)
+cancelActions as = atomically (swapTVar as mempty) >>= mapM_ (forkIO . uninterruptibleCancel)
 
 withConnLock :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m a -> m a
 withConnLock _ "" _ = id
@@ -477,68 +539,132 @@ withConnLock AgentClient {connLocks} connId name = withLockMap_ connLocks connId
 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
-    newLock = newEmptyTMVar >>= \l -> TM.insert key l locks $> l
+    newLock = createLock >>= \l -> TM.insert key l locks $> l
 
-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
+withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withClient_ c tSess@(userId, srv, _) statCmd action = do
+  cl <- getProtocolServerClient c tSess
+  (action cl <* stat cl "OK") `catchError` logServerError cl
   where
-    logServerError :: AgentErrorType -> m a
-    logServerError e = do
-      logServer "<--" c srv "" $ bshow e
+    stat cl = liftIO . incClientStat c userId 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
-  logServer "<--" c srv qId "OK"
+withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient msg -> m a) -> m a
+withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
+  logServer "-->" c srv entId cmdStr
+  res <- withClient_ c tSess cmdStr action
+  logServer "<--" c srv entId "OK"
   return res
 
-withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => 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 -> TransportSession msg -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client
 
-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 -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
+withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @msg) (clientServer client) $ action client
 
-liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
-liftClient = liftError . protocolClientError
+withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT ProtocolClientError IO a) -> m a
+withSMPClient c q cmdStr action = do
+  tSess <- mkSMPTransportSession c q
+  withLogClient c tSess (queueId q) cmdStr action
 
-protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> AgentErrorType
-protocolClientError protocolError_ = \case
+withSMPClient_ :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> m a) -> m a
+withSMPClient_ c q cmdStr action = do
+  tSess <- mkSMPTransportSession c q
+  withLogClient_ c tSess (queueId q) cmdStr action
+
+withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT ProtocolClientError IO a) -> m a
+withNtfClient c srv = withLogClient c (0, srv, Nothing)
+
+liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> HostName -> ExceptT ProtocolClientError IO a -> m a
+liftClient protocolError_ = liftError . protocolClientError protocolError_
+
+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
-  PCEIncompatibleHost -> BROKER HOST
-  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 -> ConnId -> SMPServer -> VersionRange -> m (RcvQueue, SMPQueueUri)
-newRcvQueue c connId srv vRange =
-  asks (cmdSignAlg . config) >>= \case
-    C.SignAlg a -> newRcvQueue_ a c connId srv vRange
+data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
+  deriving (Eq, Show, Generic)
 
-newRcvQueue_ ::
-  (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>
-  C.SAlgorithm a ->
-  AgentClient ->
-  ConnId ->
-  SMPServer ->
-  VersionRange ->
-  m (RcvQueue, SMPQueueUri)
-newRcvQueue_ a c connId srv vRange = 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 -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
+runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
+  cfg <- getClientConfig c smpCfg
+  C.SignAlg a <- asks $ cmdSignAlg . config
+  liftIO $ do
+    let tSess = (userId, srv, Nothing)
+    getProtocolClient tSess 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 userId 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
+
+mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
+mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c
+
+mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg
+mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing)
+
+mkSMPTransportSession :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession
+mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c
+
+mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession
+mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
+
+getSessionMode :: AgentMonad m => AgentClient -> m TransportSessionMode
+getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig
+
+newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri)
+newRcvQueue c userId 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"
+  tSess <- mkTransportSession c userId srv connId
   QIK {rcvId, sndId, rcvPublicDhKey} <-
-    withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
+    withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth
   logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
-          { connId,
+          { userId,
+            connId,
             server = srv,
             rcvId,
             rcvPrivateKey,
@@ -551,20 +677,11 @@ newRcvQueue_ a c connId srv vRange = do
             primary = True,
             dbReplaceQueueId = Nothing,
             smpClientVersion = maxVersion vRange,
-            clientNtfCreds = Nothing
+            clientNtfCreds = Nothing,
+            deleteErrors = 0
           }
   pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey)
 
-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 $ 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)
-      >>= either throwError pure
-
 processSubResult :: AgentClient -> RcvQueue -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
 processSubResult c rq r = do
   case r of
@@ -582,40 +699,73 @@ temporaryClientError = \case
 
 temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
-  BROKER NETWORK -> True
-  BROKER TIMEOUT -> True
+  BROKER _ NETWORK -> True
+  BROKER _ TIMEOUT -> True
   _ -> False
 
--- | subscribe multiple queues - all passed queues should be on the same server
-subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> [RcvQueue] -> m (Maybe SMPClient, [(RcvQueue, Either AgentErrorType ())])
-subscribeQueues c srv qs = do
-  (errs, qs_) <- partitionEithers <$> mapM checkQueue qs
-  forM_ qs_ $ \rq@RcvQueue {connId, server = _server} -> atomically $ do
-    -- TODO check server is correct
+temporaryOrHostError :: AgentErrorType -> Bool
+temporaryOrHostError = \case
+  BROKER _ HOST -> True
+  e -> temporaryAgentError e
+
+-- | Subscribe to queues. The list of results can have a different order.
+subscribeQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+subscribeQueues c qs = do
+  (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)
-      (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 qs'
-          liftIO $ do
-            rs <- zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
-            mapM_ (uncurry $ processSubResult c) rs
-            pure $ map (second . first $ protocolClientError SMP) rs
-    _ -> pure (Nothing, errs)
+  u <- askUnliftIO
+  (errs <>) <$> sendTSessionBatches "SUB" 90 (subscribeQueues_ u) c qs
   where
     checkQueue rq@RcvQueue {rcvId, server} = do
       prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
-      pure $ if prohibited || srv /= server then Left (rq, Left $ CMD PROHIBITED) else Right rq
+      pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq
+    subscribeQueues_ u smp qs' = do
+      rs <- sendBatch subscribeSMPQueues smp qs'
+      mapM_ (uncurry $ processSubResult c) rs
+      when (any temporaryClientError . lefts . map snd $ L.toList rs) $
+        unliftIO u $ reconnectServer c $ transportSession' smp
+      pure rs
+
+type BatchResponses e = (NonEmpty (RcvQueue, Either e ()))
+
+-- statBatchSize is not used to batch the commands, only for traffic statistics
+sendTSessionBatches :: forall m. AgentMonad m => ByteString -> Int -> (SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses ProtocolClientError)) -> AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+sendTSessionBatches statCmd statBatchSize action c qs =
+  concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
+  where
+    batchQueues :: m [(SMPTransportSession, NonEmpty RcvQueue)]
+    batchQueues = do
+      mode <- sessionMode <$> readTVarIO (useNetworkConfig c)
+      pure . M.assocs $ foldl' (batch mode) M.empty qs
+      where
+        batch mode m rq =
+          let tSess = mkSMPTSession rq mode
+           in M.alter (Just . maybe [rq] (rq <|)) tSess m
+    sendClientBatch :: (SMPTransportSession, NonEmpty RcvQueue) -> m (BatchResponses AgentErrorType)
+    sendClientBatch (tSess@(userId, srv, _), qs') =
+      tryError (getSMPServerClient c tSess) >>= \case
+        Left e -> pure $ L.map (,Left e) qs'
+        Right smp -> liftIO $ do
+          logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
+          rs <- L.map agentError <$> action smp qs'
+          statBatch
+          pure rs
+          where
+            agentError = second . first $ protocolClientError SMP $ clientServer smp
+            statBatch =
+              let n = (length qs - 1) `div` statBatchSize + 1
+               in incClientStatN c userId smp n (statCmd <> "S") "OK"
+
+sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses ProtocolClientError)
+sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
+  where
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
 
 addSubscription :: MonadIO m => AgentClient -> RcvQueue -> m ()
 addSubscription c rq@RcvQueue {connId} = atomically $ do
-  modifyTVar (subscrConns c) $ S.insert connId
+  modifyTVar' (subscrConns c) $ S.insert connId
   RQ.addQueue rq $ activeSubs c
   RQ.deleteQueue rq $ pendingSubs c
 
@@ -624,7 +774,7 @@ hasActiveSubscription c connId = RQ.hasConn connId $ activeSubs c
 
 removeSubscription :: AgentClient -> ConnId -> STM ()
 removeSubscription c connId = do
-  modifyTVar (subscrConns c) $ S.delete connId
+  modifyTVar' (subscrConns c) $ S.delete connId
   RQ.deleteConn connId $ activeSubs c
   RQ.deleteConn connId $ pendingSubs c
 
@@ -643,18 +793,19 @@ logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
 
 sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
-sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
-  withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
+sendConfirmation c sq@SndQueue {sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
+  withSMPClient_ c sq "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 v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo =
-  withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
+sendInvitation :: forall m. AgentMonad m => AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
+  tSess <- mkTransportSession c userId smpServer senderId
+  withLogClient_ c tSess 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
@@ -666,7 +817,7 @@ sendInvitation c (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderI
 getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
 getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
   atomically createTakeGetLock
-  (v, msg_) <- withLogClient c server rcvId "GET" $ \smp ->
+  (v, msg_) <- withSMPClient c rq "GET" $ \smp ->
     (thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId
   mapM (decryptMeta v) msg_
   where
@@ -686,23 +837,23 @@ decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.Enc
     decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
 
 secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
-secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
-  withLogClient c server rcvId "KEY <key>" $ \smp ->
+secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
+  withSMPClient c rq "KEY <key>" $ \smp ->
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
 enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (NotifierId, RcvNtfPublicDhKey)
-enableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
-  withLogClient c server rcvId "NKEY <nkey>" $ \smp ->
+enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
+  withSMPClient c rq "NKEY <nkey>" $ \smp ->
     enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
 
 disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m ()
-disableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogClient c server rcvId "NDEL" $ \smp ->
+disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
+  withSMPClient c rq "NDEL" $ \smp ->
     disableSMPQueueNotifications smp rcvPrivateKey rcvId
 
 sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
-sendAck c rq@RcvQueue {server, rcvId, rcvPrivateKey} msgId = do
-  withLogClient c server rcvId "ACK" $ \smp ->
+sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
+  withSMPClient c rq "ACK" $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId msgId
   atomically $ releaseGetLock c rq
 
@@ -711,57 +862,60 @@ releaseGetLock c RcvQueue {server, rcvId} =
   TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
 
 suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
-suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogClient c server rcvId "OFF" $ \smp ->
+suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} =
+  withSMPClient c rq "OFF" $ \smp ->
     suspendSMPQueue smp rcvPrivateKey rcvId
 
 deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
-deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
-  withLogClient c server rcvId "DEL" $ \smp ->
+deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
+  withSMPClient c rq "DEL" $ \smp ->
     deleteSMPQueue smp rcvPrivateKey rcvId
 
-sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
-sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msgFlags agentMsg =
-  withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
+deleteQueues :: forall m. AgentMonad m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
+deleteQueues = sendTSessionBatches "DEL" 90 $ sendBatch deleteSMPQueues
+
+sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
+sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg =
+  withSMPClient_ c sq "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 (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
 
 agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m ()
 agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
-  withLogClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
+  withNtfClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
 
 agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m NtfTknStatus
 agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
-  withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
+  withNtfClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
 
 agentNtfReplaceToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> m ()
 agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
-  withLogClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
+  withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
 
 agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m ()
 agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
-  withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
+  withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
 
 agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> Word16 -> m ()
 agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
-  withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
+  withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
 
 agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> NtfPrivateSignKey -> m NtfSubscriptionId
 agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
-  withLogClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
+  withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
 
 agentNtfCheckSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m NtfSubStatus
 agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
-  withLogClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
+  withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
 
 agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m ()
 agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
-  withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
+  withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
 
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
@@ -885,3 +1039,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 -> UserId -> ProtocolClient msg -> ByteString -> ByteString -> IO ()
+incClientStat c userId pc = incClientStatN c userId pc 1
+
+incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO ()
+incServerStat c userId ProtocolServer {host} cmd res = do
+  threadDelay 100000
+  atomically $ incStat c 1 statsKey
+  where
+    statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res}
+
+incClientStatN :: AgentClient -> UserId -> ProtocolClient msg -> Int -> ByteString -> ByteString -> IO ()
+incClientStatN c userId pc n cmd res = do
+  atomically $ incStat c n statsKey
+  where
+    statsKey = AgentStatsKey {userId, host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res}

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

@@ -32,12 +32,14 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map (Map)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
 import Network.Socket
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
+import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
@@ -59,7 +61,7 @@ import UnliftIO.STM
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServer,
+  { smp :: Map UserId (NonEmpty SMPServerWithAuth),
     ntf :: [NtfServer],
     netCfg :: NetworkConfig
   }
@@ -83,9 +85,12 @@ data AgentConfig = AgentConfig
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
-    messageRetryInterval :: RetryInterval,
+    messageRetryInterval :: RetryInterval2,
     messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
+    initialCleanupDelay :: Int,
+    cleanupInterval :: Int,
+    deleteErrorCount :: Int,
     ntfCron :: Word16,
     ntfWorkerDelay :: Int,
     ntfSMPWorkerDelay :: Int,
@@ -108,12 +113,24 @@ defaultReconnectInterval =
       maxInterval = 180_000000
     }
 
-defaultMessageRetryInterval :: RetryInterval
+defaultMessageRetryInterval :: RetryInterval2
 defaultMessageRetryInterval =
-  RetryInterval
-    { initialInterval = 1_000000,
-      increaseAfter = 10_000000,
-      maxInterval = 60_000000
+  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 = 30_000000,
+            increaseAfter = 30_000000,
+            maxInterval = 600_000000
+          }
     }
 
 defaultAgentConfig :: AgentConfig
@@ -131,6 +148,9 @@ defaultAgentConfig =
       messageRetryInterval = defaultMessageRetryInterval,
       messageTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
+      initialCleanupDelay = 30 * 1000000, -- 30 seconds
+      cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
+      deleteErrorCount = 10,
       ntfCron = 20, -- minutes
       ntfWorkerDelay = 100000, -- microseconds
       ntfSMPWorkerDelay = 500000, -- microseconds

src/Simplex/Messaging/Agent/Lock.hs

@@ -10,6 +10,10 @@ import UnliftIO.STM
 
 type Lock = TMVar String
 
+createLock :: STM Lock
+createLock = newEmptyTMVar
+{-# INLINE createLock #-}
+
 withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a
 withLock lock name =
   E.bracket_

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -191,7 +191,7 @@ runNtfWorker c srv doWork = do
                 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'
@@ -310,8 +310,8 @@ 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

src/Simplex/Messaging/Agent/Protocol.hs

@@ -61,9 +61,12 @@ module Simplex.Messaging.Agent.Protocol
     SndQAddr,
     SMPServer,
     pattern SMPServer,
+    pattern ProtoServerWithAuth,
+    SMPServerWithAuth,
     SrvLoc (..),
     SMPQueue (..),
     sameQAddress,
+    noAuthSrv,
     SMPQueueUri (..),
     SMPQueueInfo (..),
     SMPQueueAddress (..),
@@ -139,6 +142,7 @@ 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)
@@ -164,12 +168,15 @@ import Simplex.Messaging.Protocol
     NMsgMeta,
     ProtocolServer (..),
     SMPServer,
+    SMPServerWithAuth,
     SndPublicVerifyKey,
     SrvLoc (..),
     legacyEncodeServer,
     legacyServerP,
     legacyStrEncodeServer,
+    noAuthSrv,
     sameSrvAddr,
+    pattern ProtoServerWithAuth,
     pattern SMPServer,
   )
 import qualified Simplex.Messaging.Protocol as SMP
@@ -265,6 +272,9 @@ data ACommand (p :: AParty) where
   SWCH :: ACommand Client
   OFF :: ACommand Client
   DEL :: ACommand Client
+  DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent
+  DEL_CONN :: ACommand Agent
+  DEL_USER :: Int64 -> ACommand Agent
   CHK :: ACommand Client
   STAT :: ConnectionStats -> ACommand Agent
   OK :: ACommand Agent
@@ -304,6 +314,9 @@ data ACommandTag (p :: AParty) where
   SWCH_ :: ACommandTag Client
   OFF_ :: ACommandTag Client
   DEL_ :: ACommandTag Client
+  DEL_RCVQ_ :: ACommandTag Agent
+  DEL_CONN_ :: ACommandTag Agent
+  DEL_USER_ :: ACommandTag Agent
   CHK_ :: ACommandTag Client
   STAT_ :: ACommandTag Agent
   OK_ :: ACommandTag Agent
@@ -342,6 +355,9 @@ aCommandTag = \case
   SWCH -> SWCH_
   OFF -> OFF_
   DEL -> DEL_
+  DEL_RCVQ {} -> DEL_RCVQ_
+  DEL_CONN -> DEL_CONN_
+  DEL_USER _ -> DEL_USER_
   CHK -> CHK_
   STAT _ -> STAT_
   OK -> OK_
@@ -570,6 +586,7 @@ data AgentMessageType
   | AM_HELLO_
   | AM_REPLY_
   | AM_A_MSG_
+  | AM_QCONT_
   | AM_QADD_
   | AM_QKEY_
   | AM_QUSE_
@@ -583,6 +600,7 @@ 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"
@@ -596,6 +614,7 @@ instance Encoding AgentMessageType where
       '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_
@@ -616,6 +635,7 @@ 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_
@@ -638,6 +658,7 @@ data AMsgType
   = HELLO_
   | REPLY_
   | A_MSG_
+  | QCONT_
   | QADD_
   | QKEY_
   | QUSE_
@@ -649,6 +670,7 @@ instance Encoding AMsgType where
     HELLO_ -> "H"
     REPLY_ -> "R"
     A_MSG_ -> "M"
+    QCONT_ -> "QC"
     QADD_ -> "QA"
     QKEY_ -> "QK"
     QUSE_ -> "QU"
@@ -660,6 +682,7 @@ instance Encoding AMsgType where
       'M' -> pure A_MSG_
       'Q' ->
         A.anyChar >>= \case
+          'C' -> pure QCONT_
           'A' -> pure QADD_
           'K' -> pure QKEY_
           'U' -> pure QUSE_
@@ -677,6 +700,8 @@ 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)
@@ -694,6 +719,7 @@ instance Encoding AMessage where
     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)
@@ -704,6 +730,7 @@ instance Encoding AMessage where
         HELLO_ -> pure HELLO
         REPLY_ -> REPLY <$> smpP
         A_MSG_ -> A_MSG . unTail <$> smpP
+        QCONT_ -> QCONT <$> smpP
         QADD_ -> QADD <$> smpP
         QKEY_ -> QKEY <$> smpP
         QUSE_ -> QUSE <$> smpP
@@ -1044,7 +1071,7 @@ 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
@@ -1112,7 +1139,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
@@ -1138,23 +1164,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
 
@@ -1204,6 +1234,9 @@ instance StrEncoding ACmdTag where
       "SWCH" -> pure $ ACmdTag SClient SWCH_
       "OFF" -> pure $ ACmdTag SClient OFF_
       "DEL" -> pure $ ACmdTag SClient DEL_
+      "DEL_RCVQ" -> pure $ ACmdTag SAgent DEL_RCVQ_
+      "DEL_CONN" -> pure $ ACmdTag SAgent DEL_CONN_
+      "DEL_USER" -> pure $ ACmdTag SAgent DEL_USER_
       "CHK" -> pure $ ACmdTag SClient CHK_
       "STAT" -> pure $ ACmdTag SAgent STAT_
       "OK" -> pure $ ACmdTag SAgent OK_
@@ -1239,6 +1272,9 @@ instance APartyI p => StrEncoding (ACommandTag p) where
     SWCH_ -> "SWCH"
     OFF_ -> "OFF"
     DEL_ -> "DEL"
+    DEL_RCVQ_ -> "DEL_RCVQ"
+    DEL_CONN_ -> "DEL_CONN"
+    DEL_USER_ -> "DEL_USER"
     CHK_ -> "CHK"
     STAT_ -> "STAT"
     OK_ -> "OK"
@@ -1287,6 +1323,9 @@ commandP binaryP =
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
           MSG_ -> s (MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> binaryP)
+          DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP)
+          DEL_CONN_ -> pure DEL_CONN
+          DEL_USER_ -> s (DEL_USER <$> strP)
           STAT_ -> s (STAT <$> strP)
           OK_ -> pure OK
           ERR_ -> s (ERR <$> strP)
@@ -1335,6 +1374,9 @@ serializeCommand = \case
   SWCH -> s SWCH_
   OFF -> s OFF_
   DEL -> s DEL_
+  DEL_RCVQ srv rcvId err_ -> s (DEL_RCVQ_, srv, rcvId, err_)
+  DEL_CONN -> s DEL_CONN_
+  DEL_USER userId -> s (DEL_USER_, userId)
   CHK -> s CHK_
   STAT srvs -> s (STAT_, srvs)
   CON -> s CON_

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

@@ -34,6 +34,7 @@ import Simplex.Messaging.Protocol
     NotifierId,
     NtfPrivateSignKey,
     NtfPublicVerifyKey,
+    QueueId,
     RcvDhSecret,
     RcvNtfDhSecret,
     RcvPrivateSignKey,
@@ -47,7 +48,8 @@ import Simplex.Messaging.Version
 
 -- | A receive queue. SMP queue through which the agent receives messages from a sender.
 data RcvQueue = RcvQueue
-  { connId :: ConnId,
+  { userId :: UserId,
+    connId :: ConnId,
     server :: SMPServer,
     -- | recipient queue ID
     rcvId :: SMP.RecipientId,
@@ -72,7 +74,8 @@ data RcvQueue = RcvQueue
     -- | SMP client version
     smpClientVersion :: Version,
     -- | credentials used in context of notifications
-    clientNtfCreds :: Maybe ClientNtfCreds
+    clientNtfCreds :: Maybe ClientNtfCreds,
+    deleteErrors :: Int
   }
   deriving (Eq, Show)
 
@@ -89,7 +92,8 @@ data ClientNtfCreds = ClientNtfCreds
 
 -- | A send queue. SMP queue through which the agent sends messages to a recipient.
 data SndQueue = SndQueue
-  { connId :: ConnId,
+  { userId :: UserId,
+    connId :: ConnId,
     server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
@@ -150,6 +154,27 @@ findRQ :: (SMPServer, SMP.SenderId) -> NonEmpty RcvQueue -> Maybe RcvQueue
 findRQ sAddr = find $ sameQAddress sAddr . sndAddress
 {-# INLINE findRQ #-}
 
+class SMPQueue q => SMPQueueRec q where
+  qUserId :: q -> UserId
+  qConnId :: q -> ConnId
+  queueId :: q -> QueueId
+
+instance SMPQueueRec RcvQueue where
+  qUserId = userId
+  {-# INLINE qUserId #-}
+  qConnId = connId
+  {-# INLINE qConnId #-}
+  queueId = rcvId
+  {-# INLINE queueId #-}
+
+instance SMPQueueRec SndQueue where
+  qUserId = userId
+  {-# INLINE qUserId #-}
+  qConnId = connId
+  {-# INLINE qConnId #-}
+  queueId = sndId
+  {-# INLINE queueId #-}
+
 -- * Connection types
 
 -- | Type of a connection.
@@ -222,6 +247,7 @@ deriving instance Show SomeConn
 
 data ConnData = ConnData
   { connId :: ConnId,
+    userId :: UserId,
     connAgentVersion :: Version,
     enableNtfs :: Bool,
     duplexHandshake :: Maybe Bool, -- added in agent protocol v2
@@ -229,8 +255,17 @@ data ConnData = ConnData
   }
   deriving (Eq, Show)
 
+data PendingCommand = PendingCommand
+  { corrId :: ACorrId,
+    userId :: UserId,
+    connId :: ConnId,
+    command :: AgentCommand
+  }
+
 data AgentCmdType = ACClient | ACInternal
 
+type UserId = Int64
+
 instance StrEncoding AgentCmdType where
   strEncode = \case
     ACClient -> "CLIENT"
@@ -471,6 +506,8 @@ data StoreError
     SEInternal ByteString
   | -- | Failed to generate unique random ID
     SEUniqueID
+  | -- | User ID not found
+    SEUserNotFound
   | -- | Connection not found (or both queues absent).
     SEConnNotFound
   | -- | Connection already used.
@@ -494,8 +531,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

@@ -27,6 +27,14 @@ module Simplex.Messaging.Agent.Store.SQLite
     sqlString,
     execSQL,
 
+    -- * Users
+    createUserRecord,
+    deleteUserRecord,
+    setUserDeleted,
+    deleteUserWithoutConns,
+    deleteUsersWithoutConns,
+    checkUser,
+
     -- * Queues and connections
     createNewConn,
     updateNewConnRcv,
@@ -34,9 +42,10 @@ module Simplex.Messaging.Agent.Store.SQLite
     createRcvConn,
     createSndConn,
     getConn,
-    getAnyConn,
+    getDeletedConn,
     getConnData,
     setConnDeleted,
+    getDeletedConns,
     getRcvConn,
     deleteConn,
     upgradeRcvConnToDuplex,
@@ -49,6 +58,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     setRcvQueuePrimary,
     setSndQueuePrimary,
     deleteConnRcvQueue,
+    incRcvDeleteErrors,
     deleteConnSndQueue,
     getPrimaryRcvQueue,
     getRcvQueue,
@@ -286,7 +296,7 @@ withConnection SQLiteStore {dbConnection} =
     (atomically . putTMVar dbConnection)
 
 withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withTransaction st action = withConnection st $ loop 500 2_000_000
+withTransaction st action = withConnection st $ loop 500 3_000_000
   where
     loop :: Int -> Int -> DB.Connection -> IO a
     loop t tLim db =
@@ -297,6 +307,60 @@ withTransaction st action = withConnection st $ loop 500 2_000_000
             loop (t * 9 `div` 8) (tLim - t) db
           else E.throwIO e
 
+createUserRecord :: DB.Connection -> IO UserId
+createUserRecord db = do
+  DB.execute_ db "INSERT INTO users DEFAULT VALUES"
+  insertedRowId db
+
+checkUser :: DB.Connection -> UserId -> IO (Either StoreError ())
+checkUser db userId =
+  firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $
+    DB.query db "SELECT user_id FROM users WHERE user_id = ? AND deleted = ?" (userId, False)
+
+deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ())
+deleteUserRecord db userId = runExceptT $ do
+  ExceptT $ checkUser db userId
+  liftIO $ DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId)
+
+setUserDeleted :: DB.Connection -> UserId -> IO (Either StoreError [ConnId])
+setUserDeleted db userId = runExceptT $ do
+  ExceptT $ checkUser db userId
+  liftIO $ do
+    DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (True, userId)
+    map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE user_id = ?" (Only userId)
+
+deleteUserWithoutConns :: DB.Connection -> UserId -> IO Bool
+deleteUserWithoutConns db userId = do
+  userId_ :: Maybe Int64 <-
+    maybeFirstRow fromOnly $
+      DB.query
+        db
+        [sql|
+          SELECT user_id FROM users u
+          WHERE u.user_id = ?
+            AND u.deleted = ?
+            AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id)
+        |]
+        (userId, True)
+  case userId_ of
+    Just _ -> DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) $> True
+    _ -> pure False
+
+deleteUsersWithoutConns :: DB.Connection -> IO [Int64]
+deleteUsersWithoutConns db = do
+  userIds <-
+    map fromOnly
+      <$> DB.query
+        db
+        [sql|
+          SELECT user_id FROM users u
+          WHERE u.deleted = ?
+            AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id)
+        |]
+        (Only True)
+  forM_ userIds $ DB.execute db "DELETE FROM users WHERE user_id = ?" . Only
+  pure userIds
+
 createConn_ ::
   TVar ChaChaDRG ->
   ConnData ->
@@ -307,9 +371,9 @@ createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of
   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 =
+createNewConn db gVar cData@ConnData {userId, 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)
+    DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
 
 updateNewConnRcv :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError Int64)
 updateNewConnRcv db connId rq =
@@ -332,17 +396,17 @@ updateNewConnSnd db connId sq =
     updateConn = Right <$> addConnSndQueue_ db connId sq
 
 createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId)
-createRcvConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode =
+createRcvConn db gVar cData@ConnData {userId, 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, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+    DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
     void $ insertRcvQueue_ db connId q
 
 createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId)
-createSndConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} =
+createSndConn db gVar cData@ConnData {userId, 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, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
+    DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
     void $ insertSndQueue_ db connId q
 
 getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
@@ -455,8 +519,12 @@ setSndQueuePrimary db connId SndQueue {dbQueueId} = do
     "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} =
+incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO ()
+incRcvDeleteErrors db RcvQueue {connId, dbQueueId} =
+  DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
+
+deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO ()
+deleteConnRcvQueue db RcvQueue {connId, dbQueueId} =
   DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId)
 
 deleteConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO ()
@@ -820,13 +888,20 @@ getPendingCommands db connId = do
   where
     srvCmdId (host, port, keyHash, cmdId) = (SMPServer <$> host <*> port <*> keyHash, cmdId)
 
-getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError (ACorrId, ConnId, AgentCommand))
+getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError PendingCommand)
 getPendingCommand db msgId = do
-  firstRow id SECmdNotFound $
+  firstRow pendingCommand SECmdNotFound $
     DB.query
       db
-      "SELECT corr_id, conn_id, command FROM commands WHERE command_id = ?"
+      [sql|
+        SELECT c.corr_id, cs.user_id, c.conn_id, c.command
+        FROM commands c
+        JOIN connections cs USING (conn_id)
+        WHERE c.command_id = ?
+      |]
       (Only msgId)
+  where
+    pendingCommand (corrId, userId, connId, command) = PendingCommand {corrId, userId, connId, command}
 
 deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
 deleteCommand db cmdId =
@@ -1307,10 +1382,13 @@ newQueueId_ (Only maxId : _) = maxId + 1
 -- * getConn helpers
 
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
-getConn db connId = getAnyConn db connId False
+getConn = getAnyConn False
 
-getAnyConn :: DB.Connection -> ConnId -> Bool -> IO (Either StoreError SomeConn)
-getAnyConn dbConn connId deleted' =
+getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
+getDeletedConn = getAnyConn True
+
+getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
+getAnyConn deleted' dbConn connId =
   getConnData dbConn connId >>= \case
     Nothing -> pure $ Left SEConnNotFound
     Just (cData@ConnData {deleted}, cMode)
@@ -1328,13 +1406,16 @@ getAnyConn dbConn connId deleted' =
 
 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')
+  maybeFirstRow cData $ DB.query dbConn "SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId')
   where
-    cData (connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode)
+    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, deleted) = (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, deleted}, cMode)
 
 setConnDeleted :: DB.Connection -> ConnId -> IO ()
 setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
 
+getDeletedConns :: DB.Connection -> IO [ConnId]
+getDeletedConns db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
+
 -- | returns all connection queues, the first queue is the primary one
 getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
 getRcvQueuesByConnId_ db connId =
@@ -1348,31 +1429,32 @@ getRcvQueuesByConnId_ db connId =
 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,
+    SELECT c.user_id, s.key_hash, q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
       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.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.smp_client_version, q.delete_errors,
       q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
     FROM rcv_queues q
-    INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+    JOIN servers s ON q.host = s.host AND q.port = s.port
+    JOIN connections c ON q.conn_id = c.conn_id
   |]
 
 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)
+  (UserId, 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, Int)
     :. (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_)) =
+toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion_, deleteErrors) :. (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}
+   in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion, clientNtfCreds, deleteErrors}
 
 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)
+    DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ?") (connId, dbRcvId)
 
 -- | returns all connection queues, the first queue is the primary one
 getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue))
@@ -1381,16 +1463,17 @@ getSndQueuesByConnId_ dbConn connId =
     <$> 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, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
+        SELECT c.user_id, s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.smp_client_version
         FROM snd_queues q
-        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+        JOIN servers s ON q.host = s.host AND q.port = s.port
+        JOIN connections c ON q.conn_id = c.conn_id
         WHERE q.conn_id = ?;
       |]
       (Only connId)
   where
-    sndQueue ((keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) =
+    sndQueue ((userId, keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, smpClientVersion)) =
       let server = SMPServer host port keyHash
-       in SndQueue {connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, smpClientVersion}
+       in SndQueue {userId, 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'

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

@@ -37,6 +37,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Transport.Client (TransportHost)
 
@@ -53,7 +56,10 @@ schemaMigrations =
     ("m20220811_onion_hosts", m20220811_onion_hosts),
     ("m20220817_connection_ntfs", m20220817_connection_ntfs),
     ("m20220905_commands", m20220905_commands),
-    ("m20220915_connection_queues", m20220915_connection_queues)
+    ("m20220915_connection_queues", m20220915_connection_queues),
+    ("m20230110_users", m20230110_users),
+    ("m20230117_fkey_indexes", m20230117_fkey_indexes),
+    ("m20230120_delete_errors", m20230120_delete_errors)
   ]
 
 -- | The list of migrations in ascending order by date

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

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

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

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

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

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

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

@@ -22,7 +22,9 @@ CREATE TABLE connections(
   ,
   duplex_handshake INTEGER NULL DEFAULT 0,
   enable_ntfs INTEGER,
-  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL)
+  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL),
+  user_id INTEGER CHECK(user_id NOT NULL)
+  REFERENCES users ON DELETE CASCADE
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -45,6 +47,7 @@ CREATE TABLE rcv_queues(
   rcv_queue_id INTEGER CHECK(rcv_queue_id NOT NULL),
   rcv_primary INTEGER CHECK(rcv_primary NOT NULL),
   replace_rcv_queue_id INTEGER NULL,
+  delete_errors INTEGER DEFAULT 0 CHECK(delete_errors NOT NULL),
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -114,8 +117,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,
@@ -228,3 +231,51 @@ CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries(
   conn_id,
   snd_queue_id
 );
+CREATE TABLE users(
+  user_id INTEGER PRIMARY KEY AUTOINCREMENT
+  ,
+  deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL)
+);
+CREATE INDEX idx_connections_user ON connections(user_id);
+CREATE INDEX idx_commands_conn_id ON commands(conn_id);
+CREATE INDEX idx_commands_host_port ON commands(host, port);
+CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id);
+CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations(
+  contact_conn_id
+);
+CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages(
+  conn_id,
+  internal_snd_id
+);
+CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages(
+  conn_id,
+  internal_rcv_id
+);
+CREATE INDEX idx_messages_conn_id ON messages(conn_id);
+CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions(
+  ntf_host,
+  ntf_port
+);
+CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions(
+  smp_host,
+  smp_port
+);
+CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens(
+  ntf_host,
+  ntf_port
+);
+CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id);
+CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id);
+CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages(
+  conn_id,
+  internal_id
+);
+CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port);

src/Simplex/Messaging/Agent/TAsyncs.hs

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

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -1,18 +1,28 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Simplex.Messaging.Agent.TRcvQueues where
+module Simplex.Messaging.Agent.TRcvQueues
+  ( TRcvQueues,
+    empty,
+    clear,
+    deleteConn,
+    hasConn,
+    getConns,
+    addQueue,
+    deleteQueue,
+    getSessQueues,
+    getDelSessQueues,
+  )
+where
 
 import Control.Concurrent.STM
 import qualified Data.Map.Strict as M
 import Data.Set (Set)
 import qualified Data.Set as S
 import Simplex.Messaging.Agent.Protocol (ConnId)
-import Simplex.Messaging.Agent.Store (RcvQueue (..))
+import Simplex.Messaging.Agent.Store (RcvQueue (..), UserId)
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 
-newtype TRcvQueues = TRcvQueues (TMap (SMPServer, RecipientId) RcvQueue)
+newtype TRcvQueues = TRcvQueues (TMap (UserId, SMPServer, RecipientId) RcvQueue)
 
 empty :: STM TRcvQueues
 empty = TRcvQueues <$> TM.empty
@@ -23,28 +33,33 @@ clear (TRcvQueues qs) = TM.clear qs
 deleteConn :: ConnId -> TRcvQueues -> STM ()
 deleteConn cId (TRcvQueues qs) = modifyTVar' qs $ M.filter (\rq -> cId /= connId rq)
 
--- TODO possibly, should be limited to active queues
 hasConn :: ConnId -> TRcvQueues -> STM Bool
 hasConn cId (TRcvQueues qs) = any (\rq -> cId == connId rq) <$> readTVar qs
 
--- TODO possibly, should be limited to active queues
 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
+addQueue rq (TRcvQueues qs) = TM.insert (qKey rq) rq qs
 
 deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
-deleteQueue RcvQueue {server, rcvId} (TRcvQueues qs) = TM.delete (server, rcvId) qs
+deleteQueue rq (TRcvQueues qs) = TM.delete (qKey rq) qs
 
-getSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue]
-getSrvQueues srv (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
+getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
+getSessQueues tSess (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
   where
-    addQ qs' rq@RcvQueue {server} = if srv == server then rq : qs' else qs'
+    addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs'
 
-getDelSrvQueues :: SMPServer -> TRcvQueues -> STM [RcvQueue]
-getDelSrvQueues srv (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ ([], M.empty)
+getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
+getDelSessQueues tSess (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ ([], M.empty)
   where
-    addQ (removed, qs') rq@RcvQueue {server, rcvId}
-      | srv == server = (rq : removed, qs')
-      | otherwise = (removed, M.insert (server, rcvId) rq qs')
+    addQ (removed, qs') rq
+      | rq `isSession` tSess = (rq : removed, qs')
+      | otherwise = (removed, M.insert (qKey rq) rq qs')
+
+isSession :: RcvQueue -> (UserId, SMPServer, Maybe ConnId) -> Bool
+isSession rq (uId, srv, connId_) =
+  userId rq == uId && server rq == srv && maybe True (connId rq ==) connId_
+
+qKey :: RcvQueue -> (UserId, SMPServer, ConnId)
+qKey rq = (userId rq, server rq, connId rq)

src/Simplex/Messaging/Client.hs

@@ -26,10 +26,14 @@
 -- 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, transportHost),
+    TransportSession,
+    ProtocolClient (thVersion, sessionId, sessionTs),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
+    clientServer,
+    transportHost',
+    transportSession',
 
     -- * SMP protocol command functions
     createSMPQueue,
@@ -46,14 +50,17 @@ module Simplex.Messaging.Client
     ackSMPMessage,
     suspendSMPQueue,
     deleteSMPQueue,
+    deleteSMPQueues,
     sendProtocolCommand,
 
     -- * Supporting types and client configuration
     ProtocolClientError (..),
     ProtocolClientConfig (..),
     NetworkConfig (..),
+    TransportSessionMode (..),
     defaultClientConfig,
     defaultNetworkConfig,
+    transportClientConfig,
     chooseTransportHost,
     ServerTransmission,
   )
@@ -72,23 +79,26 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (rights)
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.List (find)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import GHC.Generics (Generic)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
 import Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), 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)
 
@@ -96,13 +106,19 @@ 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,
-    protocolServer :: ProtoServer msg,
+    client_ :: PClient msg
+  }
+
+data PClient msg = PClient
+  { connected :: TVar Bool,
+    transportSession :: TransportSession msg,
     transportHost :: TransportHost,
     tcpTimeout :: Int,
+    pingErrorCount :: TVar Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TMap CorrId (Request msg),
     sndQ :: TBQueue (NonEmpty SentRawTransmission),
@@ -116,7 +132,7 @@ type SMPClient = ProtocolClient SMP.BrokerMsg
 type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
 
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
+type ServerTransmission msg = (TransportSession msg, Version, SessionId, QueueId, msg)
 
 data HostMode
   = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
@@ -142,14 +158,19 @@ data NetworkConfig = NetworkConfig
     hostMode :: HostMode,
     -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
     requiredHostMode :: Bool,
+    -- | transport sessions are created per user or per entity
+    sessionMode :: TransportSessionMode,
     -- | timeout for the initial client TCP/TLS connection (microseconds)
     tcpConnectTimeout :: Int,
     -- | timeout of protocol commands (microseconds)
     tcpTimeout :: Int,
     -- | TCP keep-alive options, Nothing to skip enabling keep-alive
     tcpKeepAlive :: Maybe KeepAliveOpts,
-    -- | period for SMP ping commands (microseconds)
-    smpPingInterval :: Int
+    -- | period for SMP ping commands (microseconds, 0 to disable)
+    smpPingInterval :: Int,
+    -- | the count of PING errors after which SMP client terminates (and will be reconnected), 0 to disable
+    smpPingCount :: Int,
+    logTLSErrors :: Bool
   }
   deriving (Eq, Show, Generic, FromJSON)
 
@@ -157,18 +178,35 @@ instance ToJSON NetworkConfig where
   toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
   toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
 
+data TransportSessionMode = TSMUser | TSMEntity
+  deriving (Eq, Show, Generic)
+
+instance ToJSON TransportSessionMode where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "TSM"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TSM"
+
+instance FromJSON TransportSessionMode where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "TSM"
+
 defaultNetworkConfig :: NetworkConfig
 defaultNetworkConfig =
   NetworkConfig
     { socksProxy = Nothing,
       hostMode = HMOnionViaSocks,
       requiredHostMode = False,
+      sessionMode = TSMUser,
       tcpConnectTimeout = 7_500_000,
       tcpTimeout = 5_000_000,
       tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPingInterval = 600_000_000 -- 10min
+      smpPingInterval = 600_000_000, -- 10min
+      smpPingCount = 3,
+      logTLSErrors = False
     }
 
+transportClientConfig :: NetworkConfig -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
+  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
+
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
@@ -212,36 +250,51 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts
     onionHost = find isOnionHost hosts
     publicHost = find (not . isOnionHost) hosts
 
+clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient msg -> String
+clientServer = B.unpack . strEncode . snd3 . transportSession . client_
+  where
+    snd3 (_, s, _) = s
+
+transportHost' :: ProtocolClient msg -> TransportHost
+transportHost' = transportHost . client_
+
+transportSession' :: ProtocolClient msg -> TransportSession msg
+transportSession' = transportSession . client_
+
+type UserId = Int64
+
+-- | Transport session key - includes entity ID if `sessionMode = TSMEntity`.
+type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
+
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
-  case chooseTransportHost networkConfig (host protocolServer) of
+getProtocolClient :: forall msg. Protocol msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
+getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
+  case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
         `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
     Left e -> pure $ Left e
   where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpKeepAlive, socksProxy, smpPingInterval} = networkConfig
-    mkProtocolClient :: TransportHost -> STM (ProtocolClient msg)
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    mkProtocolClient :: TransportHost -> STM (PClient msg)
     mkProtocolClient transportHost = do
       connected <- newTVar False
+      pingErrorCount <- newTVar 0
       clientCorrId <- newTVar 0
       sentCommands <- TM.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
       return
-        ProtocolClient
-          { action = undefined,
-            sessionId = undefined,
-            thVersion = undefined,
-            connected,
-            protocolServer,
+        PClient
+          { connected,
+            transportSession,
             transportHost,
             tcpTimeout,
+            pingErrorCount,
             clientCorrId,
             sentCommands,
             sndQ,
@@ -249,54 +302,65 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> TransportHost -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
+    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
     runClient (port', ATransport t) useHost c = do
-      thVar <- newEmptyTMVarIO
+      cVar <- newEmptyTMVarIO
+      let tcConfig = transportClientConfig networkConfig
+          username = proxyUsername transportSession
       action <-
         async $
-          runTransportClient socksProxy useHost port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
-            `finally` atomically (putTMVar thVar $ Left PCENetworkError)
-      th_ <- tcpConnectTimeout `timeout` atomically (takeTMVar thVar)
-      pure $ case th_ of
-        Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
+          runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
+            `finally` atomically (putTMVar cVar $ Left PCENetworkError)
+      c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
+      pure $ case c_ of
+        Just (Right c') -> Right c' {action = Just action}
         Just (Left e) -> Left e
         Nothing -> Left PCENetworkError
 
+    proxyUsername :: TransportSession msg -> ByteString
+    proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
+
     useTransport :: (ServiceName, ATransport)
-    useTransport = case port protocolServer of
+    useTransport = case port srv of
       "" -> defaultTransport cfg
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
-    client _ c thVar h =
-      runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
-        Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
+    client :: forall c. Transport c => TProxy c -> PClient msg -> TMVar (Either ProtocolClientError (ProtocolClient msg)) -> c -> IO ()
+    client _ c cVar h =
+      runExceptT (protocolClientHandshake @msg h (keyHash srv) smpServerVRange) >>= \case
+        Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {sessionId, thVersion} -> do
+          sessionTs <- getCurrentTime
+          let c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs}
           atomically $ do
             writeTVar (connected c) True
-            putTMVar thVar $ Right th
-          let c' = c {sessionId, thVersion} :: ProtocolClient msg
-          -- TODO remove ping if 0 is passed (or Nothing?)
-          raceAny_ [send c' th, process c', receive c' th, ping c']
+            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
+    ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do
       threadDelay smpPingInterval
-      runExceptT $ sendProtocolCommand c Nothing "" protocolPing
+      runExceptT (sendProtocolCommand c Nothing "" protocolPing) >>= \case
+        Left PCEResponseTimeout -> do
+          cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1)
+          when (maxCnt == 0 || cnt < maxCnt) $ ping c
+        _ -> ping c -- sendProtocolCommand resets pingErrorCount
+      where
+        maxCnt = smpPingCount networkConfig
 
     process :: ProtocolClient msg -> IO ()
-    process c = 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
@@ -316,12 +380,11 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
         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
@@ -361,9 +424,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
 
@@ -389,11 +453,11 @@ 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 =
-  (protocolServer, thVersion, sessionId, entityId, message)
+serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {transportSession}} entityId message =
+  (transportSession, thVersion, sessionId, entityId, message)
 
 -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
 --
@@ -444,13 +508,7 @@ disableSMPQueueNotifications = okSMPCommand NDEL
 
 -- | Disable notifications for multiple queues for push notifications server.
 disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
-disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
-  where
-    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs
-    response = \case
-      Right OK -> Right ()
-      Right r -> Left . PCEUnexpectedResponse $ bshow r
-      Left e -> Left e
+disableSMPQueuesNtfs = okSMPCommands NDEL
 
 -- | Send SMP message.
 --
@@ -481,46 +539,62 @@ suspendSMPQueue = okSMPCommand OFF
 -- | Irreversibly delete SMP queue and all messages in it.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
-deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 
+-- | Delete multiple SMP queues batching commands if supported.
+deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
+deleteSMPQueues = okSMPCommands DEL
+
 okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
+okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either ProtocolClientError ()))
+okSMPCommands cmd c qs = L.map response <$> sendProtocolCommands c cs
+  where
+    aCmd = Cmd sParty cmd
+    cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
+    response = \case
+      Right OK -> Right ()
+      Right r -> Left . PCEUnexpectedResponse $ bshow r
+      Left e -> Left e
+
 -- | Send SMP command
 sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
 sendSMPCommand 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}} cs = do
   ts <- mapM (runExceptT . mkTransmission c) cs
   mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
   forConcurrently ts $ \case
-    Right (_, r) -> withTimeout . atomically $ takeTMVar r
+    Right (_, r) -> withTimeout c $ atomically $ takeTMVar r
     Left e -> pure $ Left e
-  where
-    withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
 
 -- | 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}} pKey qId cmd = do
   (t, r) <- mkTransmission c (pKey, qId, cmd)
   ExceptT $ sendRecv t r
   where
     -- two separate "atomically" needed to avoid blocking
     sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
-    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r)
-      where
-        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
+    sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout c (atomically $ takeTMVar r)
+
+withTimeout :: ProtocolClient msg -> IO (Either ProtocolClientError msg) -> IO (Either ProtocolClientError msg)
+withTimeout ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} a =
+  timeout tcpTimeout a >>= \case
+    Just r -> atomically (writeTVar pingErrorCount 0) >> pure r
+    _ -> pure $ Left PCEResponseTimeout
 
 mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
-mkTransmission 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
@@ -528,12 +602,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

@@ -160,7 +160,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
             void $ tryConnectClient (const reconnectClient) loop
 
     connectClient :: ExceptT ProtocolClientError IO SMPClient
-    connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
+    connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected _ = do

src/Simplex/Messaging/Crypto.hs

@@ -67,7 +67,9 @@ module Simplex.Messaging.Crypto
 
     -- * key encoding/decoding
     encodePubKey,
+    decodePubKey,
     encodePrivKey,
+    decodePrivKey,
     pubKeyBytes,
 
     -- * sign/verify
@@ -888,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.
 --
@@ -962,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

@@ -472,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/Notifications/Server.hs

@@ -66,7 +66,7 @@ runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtf
 type M a = ReaderT NtfEnv IO a
 
 ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
-ntfServer cfg@NtfServerConfig {transports} started = do
+ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
   restoreServerStats
   s <- asks subscriber
   ps <- asks pushServer
@@ -77,7 +77,7 @@ ntfServer cfg@NtfServerConfig {transports} started = do
     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 _ h = do
@@ -190,7 +190,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
     receiveSMP :: M ()
     receiveSMP = forever $ do
-      (srv, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
+      ((_, srv, _), _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
       let smpQueue = SMPQueueNtf srv ntfId
       case msg of
         SMP.NMSG nmsgNonce encNMsgMeta -> do
@@ -257,24 +257,27 @@ 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 _) ->
-      -- 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) ->
+  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
       incNtfStat ntfDelivered
-    _ ->
-      liftIO $ logError "bad notification token status"
   where
+    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
@@ -283,7 +286,6 @@ 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
@@ -362,21 +364,19 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
       s_ <- atomically $ findNtfSubscription st smpQueue
       case s_ of
         Nothing -> do
-          -- TODO move active token check here to differentiate error
           t_ <- atomically $ getActiveNtfToken st tknId
           verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub))
         Just s@NtfSubData {tokenId = subTknId} ->
           if subTknId == tknId
             then do
-              -- TODO move active token check here to differentiate error
               t_ <- atomically $ getActiveNtfToken st subTknId
               verifyToken' t_ $ verifiedSubCmd s c
             else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+    NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId
     NtfCmd SSubscription c -> do
       s_ <- atomically $ getNtfSubscription st entId
       case s_ of
         Just s@NtfSubData {tokenId = subTknId} -> do
-          -- TODO move active token check here to differentiate error
           t_ <- atomically $ getActiveNtfToken st subTknId
           verifyToken' t_ $ verifiedSubCmd s c
         _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
@@ -513,7 +513,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         (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
@@ -530,6 +530,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             incNtfStat subDeleted
             pure NROk
           PING -> pure NRPong
+      NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
     getId :: M NtfEntityId
     getId = getRandomBytes =<< asks (subIdBytes . config)
     getRegCode :: M NtfRegCode
@@ -549,7 +550,7 @@ withNtfLog action = liftIO . mapM_ action =<< asks storeLog
 incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
 incNtfStat statSel = do
   stats <- asks serverStats
-  atomically $ modifyTVar (statSel stats) (+ 1)
+  atomically $ modifyTVar' (statSel stats) (+ 1)
 
 saveServerStats :: M ()
 saveServerStats =

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

@@ -55,7 +55,8 @@ data NtfServerConfig = NtfServerConfig
     logStatsInterval :: Maybe Int,
     logStatsStartTime :: Int,
     serverStatsLogFile :: FilePath,
-    serverStatsBackupFile :: Maybe FilePath
+    serverStatsBackupFile :: Maybe FilePath,
+    logTLSErrors :: Bool
   }
 
 defaultInactiveClientExpiration :: ExpirationConfig
@@ -147,6 +148,7 @@ getPushClient s@NtfPushServer {pushClients} pp =
 data NtfRequest
   = NtfReqNew CorrId ANewNtfEntity
   | forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
+  | NtfReqPing CorrId NtfEntityId
 
 data NtfServerClient = NtfServerClient
   { rcvQ :: TBQueue NtfRequest,

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

@@ -0,0 +1,174 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Simplex.Messaging.Notifications.Server.Main where
+
+import Data.Either (fromRight)
+import Data.Functor (($>))
+import Data.Ini (lookupValue, readIniFile)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Network.Socket (HostName)
+import Options.Applicative
+import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Notifications.Server (runNtfServer)
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
+import Simplex.Messaging.Server.CLI
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.FilePath (combine)
+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
+import Text.Read (readMaybe)
+
+ntfServerVersion :: String
+ntfServerVersion = "1.3.0"
+
+ntfServerCLI :: FilePath -> FilePath -> IO ()
+ntfServerCLI cfgPath logPath =
+  getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
+    Init opts ->
+      doesFileExist iniFile >>= \case
+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
+        _ -> initializeServer opts
+    Start ->
+      doesFileExist iniFile >>= \case
+        True -> readIniFile iniFile >>= either exitError runServer
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
+    Delete -> do
+      confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
+      deleteDirIfExists cfgPath
+      deleteDirIfExists logPath
+      putStrLn "Deleted configuration and log files"
+  where
+    iniFile = combine cfgPath "ntf-server.ini"
+    serverVersion = "SMP notifications server v" <> ntfServerVersion
+    defaultServerPort = "443"
+    executableName = "ntf-server"
+    storeLogFilePath = combine logPath "ntf-server-store.log"
+    initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
+      clearDirIfExists cfgPath
+      clearDirIfExists logPath
+      createDirectoryIfMissing True cfgPath
+      createDirectoryIfMissing True logPath
+      let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
+      fp <- createServerX509 cfgPath x509cfg
+      let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing
+      writeFile iniFile $ iniFileContent host
+      putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
+      warnCAPrivateKeyFile cfgPath x509cfg
+      printServiceInfo serverVersion srv
+      where
+        iniFileContent host =
+          "[STORE_LOG]\n\
+          \# The server uses STM memory for persistence,\n\
+          \# that will be lost on restart (e.g., as with redis).\n\
+          \# This option enables saving memory to append only log,\n\
+          \# and restoring it when the server is started.\n\
+          \# Log is compacted on start (deleted objects are removed).\n"
+            <> ("enable: " <> onOff enableStoreLog <> "\n\n")
+            <> "log_stats: off\n\n\
+               \[TRANSPORT]\n\
+               \# host is only used to print server address on start\n"
+            <> ("host: " <> host <> "\n")
+            <> ("port: " <> defaultServerPort <> "\n")
+            <> "log_tls_errors: off\n\
+               \websockets: off\n"
+    runServer ini = do
+      hSetBuffering stdout LineBuffering
+      hSetBuffering stderr LineBuffering
+      fp <- checkSavedFingerprint cfgPath defaultX509Config
+      let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
+          port = T.unpack $ strictIni "TRANSPORT" "port" ini
+          cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
+          srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
+      printServiceInfo serverVersion srv
+      printServerConfig transports storeLogFile
+      runNtfServer cfg
+      where
+        enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+        logStats = settingIsOn "STORE_LOG" "log_stats" ini
+        c = combine cfgPath . ($ defaultX509Config)
+        serverConfig =
+          NtfServerConfig
+            { transports = iniTransports ini,
+              subIdBytes = 24,
+              regCodeBytes = 32,
+              clientQSize = 16,
+              subQSize = 64,
+              pushQSize = 128,
+              smpAgentCfg = defaultSMPClientAgentConfig,
+              apnsConfig = defaultAPNSPushClientConfig,
+              inactiveClientExpiration = Nothing,
+              storeLogFile = enableStoreLog $> storeLogFilePath,
+              resubscribeDelay = 50000, -- 50ms
+              caCertificateFile = c caCrtFile,
+              privateKeyFile = c serverKeyFile,
+              certificateFile = c serverCrtFile,
+              logStatsInterval = logStats $> 86400, -- seconds
+              logStatsStartTime = 0, -- seconds from 00:00 UTC
+              serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
+              serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
+              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
+            }
+
+data CliCommand
+  = Init InitOptions
+  | Start
+  | Delete
+
+data InitOptions = InitOptions
+  { enableStoreLog :: Bool,
+    signAlgorithm :: SignAlgorithm,
+    ip :: HostName,
+    fqdn :: Maybe HostName
+  }
+  deriving (Show)
+
+cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
+cliCommandP cfgPath logPath iniFile =
+  hsubparser
+    ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
+        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
+        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
+    )
+  where
+    initP :: Parser InitOptions
+    initP =
+      InitOptions
+        <$> switch
+          ( long "store-log"
+              <> short 'l'
+              <> help "Enable store log for persistence"
+          )
+        <*> option
+          (maybeReader readMaybe)
+          ( long "sign-algorithm"
+              <> short 'a'
+              <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
+              <> value ED448
+              <> showDefault
+              <> metavar "ALG"
+          )
+        <*> strOption
+          ( long "ip"
+              <> help
+                "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
+              <> value "127.0.0.1"
+              <> showDefault
+              <> metavar "IP"
+          )
+        <*> (optional . strOption)
+          ( long "fqdn"
+              <> short 'n'
+              <> help "Server FQDN used as Common Name for TLS online certificate"
+              <> showDefault
+              <> metavar "FQDN"
+          )

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

@@ -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,14 +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}
+    -- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
 
 apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
 apnsRequest c tkn ntf@APNSNotification {aps} = do
@@ -357,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

@@ -70,14 +70,14 @@ getNtfServerStatsData s = do
 
 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)
+  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)
 

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

@@ -106,7 +106,7 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
       forM_ tIds $ \(regKey, tId') -> do
         TM.delete regKey tknRegs
         TM.delete tId' $ tokens st
-        -- TODO remove token subscriptions as in deleteNtfToken
+        void $ deleteTokenSubs st tId'
       pure $ map snd tIds
 
 removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
@@ -120,37 +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
-              )
-      )
-
-  -- TODO refactor
-  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/Protocol.hs

@@ -70,10 +70,14 @@ module Simplex.Messaging.Protocol
     ProtoServer,
     SMPServer,
     pattern SMPServer,
+    SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    ProtoServerWithAuth (..),
+    BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
+    EntityId,
     QueueId,
     RecipientId,
     SenderId,
@@ -116,6 +120,8 @@ module Simplex.Messaging.Protocol
     legacyServerP,
     legacyStrEncodeServer,
     sameSrvAddr,
+    sameSrvAddr',
+    noAuthSrv,
 
     -- * TCP transport functions
     tPut,
@@ -129,12 +135,14 @@ 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
@@ -250,7 +258,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
@@ -297,12 +305,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} =
@@ -322,44 +335,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
 
@@ -371,7 +412,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,
@@ -566,6 +609,8 @@ pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
 
 {-# COMPLETE SMPServer #-}
 
+type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
+
 type NtfServer = ProtocolServer 'PNTF
 
 pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
@@ -573,6 +618,10 @@ 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 #-}
@@ -667,20 +716,57 @@ instance ProtocolTypeI p => Encoding (ProtocolServer p) where
 
 instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
   strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncodeServer scheme (strEncode host) port keyHash
-  strP = do
-    scheme <- strP <* "://"
-    keyHash <- strP <* A.char '@'
-    TransportHosts host <- strP
-    port <- portP <|> pure ""
-    pure ProtocolServer {scheme, host, port, keyHash}
-    where
-      portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+    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 {protoServer :: ProtocolServer p, serverBasicAuth :: 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)
@@ -692,14 +778,25 @@ legacyServerP = do
 
 legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
 legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
-  strEncodeServer scheme (strEncode $ L.head host) port keyHash
+  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
 
-strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> ByteString
-strEncodeServer scheme host port keyHash =
-  strEncode scheme <> "://" <> strEncode keyHash <> "@" <> host <> portStr
+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)
 
@@ -792,7 +889,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
@@ -870,7 +967,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)
@@ -918,7 +1021,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
@@ -1054,26 +1161,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

@@ -65,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)
@@ -97,16 +97,15 @@ 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 :: TMVar Bool -> ServerConfig -> IO ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
+runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started cfg)
 
 type M a = ReaderT Env IO a
 
-smpServer :: TMVar Bool -> M ()
-smpServer started = do
+smpServer :: TMVar Bool -> ServerConfig -> M ()
+smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
   s <- asks server
-  cfg@ServerConfig {transports} <- asks config
-  restoreServerStats
   restoreServerMessages
+  restoreServerStats
   raceAny_
     ( serverThread s subscribedQ subscribers subscriptions cancelSub :
       serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
@@ -117,7 +116,7 @@ smpServer started = do
     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.
@@ -175,7 +174,7 @@ smpServer started = 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, activeQueues} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
       let interval = 1000000 * logInterval
       withFile statsFilePath AppendMode $ \h -> liftIO $ do
         hSetBuffering h LineBuffering
@@ -188,7 +187,31 @@ smpServer started = do
           msgSent' <- atomically $ swapTVar msgSent 0
           msgRecv' <- atomically $ swapTVar msgRecv 0
           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]
+          msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
+          msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
+          psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
+          qCount' <- readTVarIO qCount
+          msgCount' <- readTVarIO msgCount
+          hPutStrLn h $
+            intercalate
+              ","
+              [ iso8601Show $ utctDay fromTime',
+                show qCreated',
+                show qSecured',
+                show qDeleted',
+                show msgSent',
+                show msgRecv',
+                dayCount ps,
+                weekCount ps,
+                monthCount ps,
+                show msgSentNtf',
+                show msgRecvNtf',
+                dayCount psNtf,
+                weekCount psNtf,
+                monthCount psNtf,
+                show qCount',
+                show msgCount'
+              ]
           threadDelay interval
 
     runClient :: Transport c => TProxy c -> c -> M ()
@@ -257,7 +280,6 @@ receive th Client {rcvQ, sndQ, activeAt} = forever $ do
 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
@@ -280,7 +302,7 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 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
@@ -323,7 +345,7 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
+client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= mapM processCommand
@@ -340,11 +362,15 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
         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)
@@ -384,7 +410,8 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
                 Right _ -> do
                   withLog (`logCreateById` rId)
                   stats <- asks serverStats
-                  atomically $ modifyTVar (qCreated stats) (+ 1)
+                  atomically $ modifyTVar' (qCreated stats) (+ 1)
+                  atomically $ modifyTVar' (qCount stats) (+ 1)
                   subscribeQueue qr rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
@@ -402,7 +429,7 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
         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)
@@ -507,12 +534,12 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
                   q <- getStoreMsgQueue "ACK" queueId
                   case s of
                     Sub {subThread = ProhibitSub} -> do
-                      msgDeleted <- atomically $ tryDelMsg q msgId
-                      when msgDeleted updateStats
+                      deletedMsg_ <- atomically $ tryDelMsg q msgId
+                      mapM_ updateStats deletedMsg_
                       pure ok
                     _ -> do
-                      (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
-                      when msgDeleted updateStats
+                      (deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId
+                      mapM_ updateStats deletedMsg_
                       deliverMessage "ACK" qr queueId sub q msg_
                 _ -> pure $ err NO_MSG
           where
@@ -523,11 +550,17 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
                 if msgId == msgId' || B.null msgId
                   then pure $ Just s
                   else putTMVar delivered msgId' $> Nothing
-            updateStats :: m ()
-            updateStats = do
-              stats <- asks serverStats
-              atomically $ modifyTVar (msgRecv stats) (+ 1)
-              atomically $ updatePeriodStats (activeQueues stats) queueId
+            updateStats :: Message -> m ()
+            updateStats = \case
+              MessageQuota {} -> pure ()
+              Message {msgFlags} -> do
+                stats <- asks serverStats
+                atomically $ modifyTVar' (msgRecv stats) (+ 1)
+                atomically $ modifyTVar' (msgCount stats) (+ 1)
+                atomically $ updatePeriodStats (activeQueues stats) queueId
+                when (notification msgFlags) $ do
+                  atomically $ modifyTVar' (msgRecvNtf stats) (+ 1)
+                  atomically $ updatePeriodStats (activeQueuesNtf stats) queueId
 
         sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
         sendMessage qr msgFlags msgBody
@@ -535,20 +568,25 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
           | 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
-                  resp@(_, _, sent) <- time "SEND" $ do
+                Right body -> do
+                  msg_ <- time "SEND" $ do
                     q <- getStoreMsgQueue "SEND" $ recipientId qr
                     expireMessages q
-                    atomically $ ifM (isFull q) (pure $ err QUOTA) (writeMsg q msg $> ok)
-                  when (sent == OK) . 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 resp
+                    atomically . writeMsg q =<< mkMessage body
+                  case msg_ of
+                    Nothing -> pure $ err QUOTA
+                    Just msg -> time "SEND ok" $ do
+                      stats <- asks serverStats
+                      when (notification msgFlags) $ do
+                        atomically . trySendNotification msg =<< asks idsDrg
+                        atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
+                        atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
+                      atomically $ modifyTVar' (msgSent stats) (+ 1)
+                      atomically $ modifyTVar' (msgCount stats) (subtract 1)
+                      atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
+                      pure ok
           where
             mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
             mkMessage body = do
@@ -569,12 +607,14 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
 
             writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
             writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
-              unlessM (isFullTBQueue q) $ 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
@@ -593,9 +633,9 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
           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
@@ -606,23 +646,28 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
                     writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
                     s <- readTVar sub
                     void $ setDelivered s msg
-                    writeTVar sub s {subThread = NoSub}
+                    writeTVar sub $! s {subThread = NoSub}
 
         time :: T.Text -> m a -> m a
-        time name = timed name sessionId queueId
+        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 :: T.Text -> RecipientId -> m MsgQueue
         getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
@@ -635,7 +680,8 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
           withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
           stats <- asks serverStats
-          atomically $ modifyTVar (qDeleted stats) (+ 1)
+          atomically $ modifyTVar' (qDeleted stats) (+ 1)
+          atomically $ modifyTVar' (qCount stats) (subtract 1)
           atomically $
             deleteQueue st queueId >>= \case
               Left e -> pure $ err e
@@ -655,13 +701,13 @@ withLog action = do
   env <- ask
   liftIO . mapM_ action $ storeLog (env :: Env)
 
-timed :: MonadUnliftIO m => T.Text -> ByteString -> RecipientId -> m a -> m a
-timed name sessId qId a = do
+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 sessId, tshow $ encode qId, tshow int]
+  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)
@@ -714,8 +760,11 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
             addToMsgQueue rId msg = do
               full <- atomically $ do
                 q <- getMsgQueue ms rId quota
-                ifM (isFull q) (pure True) (writeMsg q msg $> False)
-              when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
+                isNothing <$> writeMsg q msg
+              case msg of
+                Message {} ->
+                  when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
+                MessageQuota {} -> pure ()
             updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
               let nonce = C.cbNonce msgId
               msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
@@ -741,7 +790,9 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          atomically $ setServerStats s d
+          _qCount <- fmap (length . M.keys) . readTVarIO . queues =<< asks queueStore
+          _msgCount <- foldM (\n q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore
+          atomically $ setServerStats s d {_qCount, _msgCount}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
         Left e -> do

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 (Maybe Message)
+tryDelMsg mq msgId' =
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_
+      | otherwise -> pure Nothing
+    _ -> pure Nothing
 
-  tryDelMsg :: MsgQueue -> MsgId -> STM Bool
-  tryDelMsg (MsgQueue q) msgId' =
-    tryPeekTBQueue q >>= \case
-      Just Message {msgId}
-        | msgId == msgId' || B.null msgId' -> tryReadTBQueue q $> True
-        | otherwise -> pure False
-      _ -> pure False
+-- atomic delete (== read) last and peek next message if available
+tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message)
+tryDelPeekMsg mq msgId' =
+  tryPeekMsg mq >>= \case
+    msg_@(Just msg)
+      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
+      | otherwise -> pure (Nothing, msg_)
+    _ -> pure (Nothing, Nothing)
 
-  -- atomic delete (== read) last and peek next message if available
-  tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Bool, Maybe Message)
-  tryDelPeekMsg (MsgQueue q) msgId' =
-    tryPeekTBQueue q >>= \case
-      msg_@(Just Message {msgId})
-        | msgId == msgId' || B.null msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
-        | otherwise -> pure (False, msg_)
-      _ -> pure (False, Nothing)
-
-  deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
-  deleteExpiredMsgs (MsgQueue q) old = loop
-    where
-      loop = tryPeekTBQueue q >>= mapM_ delOldMsg
-      delOldMsg Message {msgTs} =
+deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
+deleteExpiredMsgs mq old = loop
+  where
+    loop = tryPeekMsg mq >>= mapM_ delOldMsg
+    delOldMsg = \case
+      Message {msgTs} ->
         when (systemSeconds msgTs < old) $
-          tryReadTBQueue q >> loop
+          tryDeleteMsg mq >> loop
+      _ -> pure ()
+
+tryDeleteMsg :: MsgQueue -> STM ()
+tryDeleteMsg MsgQueue {msgQueue = q, size} =
+  tryReadTQueue q >>= \case
+    Just _ -> modifyTVar' size (subtract 1)
+    _ -> pure ()

src/Simplex/Messaging/Server/QueueStore.hs

@@ -9,20 +9,20 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 
 data QueueRec = QueueRec
-  { recipientId :: RecipientId,
-    recipientKey :: RcvPublicVerifyKey,
-    rcvDhSecret :: RcvDhSecret,
-    senderId :: SenderId,
-    senderKey :: Maybe SndPublicVerifyKey,
-    notifier :: Maybe NtfCreds,
-    status :: ServerQueueStatus
+  { 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)
 
@@ -33,12 +33,3 @@ instance StrEncoding NtfCreds where
     pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
 
 data ServerQueueStatus = 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 ())

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,66 +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 k -> pure $ if sKey == k then Just q else Nothing
-        _ ->
-          let q' = q {senderKey = Just sKey}
-          in writeTVar qVar q' $> 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,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -5,7 +6,7 @@
 
 module Simplex.Messaging.Server.Stats where
 
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Set (Set)
@@ -24,7 +25,12 @@ data ServerStats = ServerStats
     qDeleted :: TVar Int,
     msgSent :: TVar Int,
     msgRecv :: TVar Int,
-    activeQueues :: PeriodStats RecipientId
+    activeQueues :: PeriodStats RecipientId,
+    msgSentNtf :: TVar Int,
+    msgRecvNtf :: TVar Int,
+    activeQueuesNtf :: PeriodStats RecipientId,
+    qCount :: TVar Int,
+    msgCount :: TVar Int
   }
 
 data ServerStatsData = ServerStatsData
@@ -34,8 +40,14 @@ data ServerStatsData = ServerStatsData
     _qDeleted :: Int,
     _msgSent :: Int,
     _msgRecv :: Int,
-    _activeQueues :: PeriodStatsData RecipientId
+    _activeQueues :: PeriodStatsData RecipientId,
+    _msgSentNtf :: Int,
+    _msgRecvNtf :: Int,
+    _activeQueuesNtf :: PeriodStatsData RecipientId,
+    _qCount :: Int,
+    _msgCount :: Int
   }
+  deriving (Show)
 
 newServerStats :: UTCTime -> STM ServerStats
 newServerStats ts = do
@@ -46,7 +58,12 @@ newServerStats ts = do
   msgSent <- newTVar 0
   msgRecv <- newTVar 0
   activeQueues <- newPeriodStats
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues}
+  msgSentNtf <- newTVar 0
+  msgRecvNtf <- newTVar 0
+  activeQueuesNtf <- newPeriodStats
+  qCount <- newTVar 0
+  msgCount <- newTVar 0
+  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
@@ -57,20 +74,30 @@ getServerStatsData s = do
   _msgSent <- readTVar $ msgSent s
   _msgRecv <- readTVar $ msgRecv s
   _activeQueues <- getPeriodStatsData $ activeQueues s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
+  _msgSentNtf <- readTVar $ msgSentNtf s
+  _msgRecvNtf <- readTVar $ msgRecvNtf s
+  _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
+  _qCount <- readTVar $ qCount s
+  _msgCount <- readTVar $ msgCount s
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
 
 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)
+  writeTVar (fromTime s) $! _fromTime d
+  writeTVar (qCreated s) $! _qCreated d
+  writeTVar (qSecured s) $! _qSecured d
+  writeTVar (qDeleted s) $! _qDeleted d
+  writeTVar (msgSent s) $! _msgSent d
+  writeTVar (msgRecv s) $! _msgRecv d
   setPeriodStats (activeQueues s) (_activeQueues d)
+  writeTVar (msgSentNtf s) $! _msgSentNtf d
+  writeTVar (msgRecvNtf s) $! _msgRecvNtf d
+  setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
+  writeTVar (qCount s) $! _qCount d
+  writeTVar (msgCount s) $! _qCount d
 
 instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues} =
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "qCreated=" <> strEncode _qCreated,
@@ -78,8 +105,12 @@ instance StrEncoding ServerStatsData where
         "qDeleted=" <> strEncode _qDeleted,
         "msgSent=" <> strEncode _msgSent,
         "msgRecv=" <> strEncode _msgRecv,
+        "msgSentNtf=" <> strEncode _msgSentNtf,
+        "msgRecvNtf=" <> strEncode _msgRecvNtf,
         "activeQueues:",
-        strEncode _activeQueues
+        strEncode _activeQueues,
+        "activeQueuesNtf:",
+        strEncode _activeQueuesNtf
       ]
   strP = do
     _fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -88,15 +119,21 @@ instance StrEncoding ServerStatsData where
     _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
     _msgSent <- "msgSent=" *> strP <* A.endOfLine
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    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}
+    _msgSentNtf <- "msgSentNtf=" *> strP <* A.endOfLine <|> pure 0
+    _msgRecvNtf <- "msgRecvNtf=" *> strP <* A.endOfLine <|> pure 0
+    _activeQueues <-
+      optional ("activeQueues:" <* A.endOfLine) >>= \case
+        Just _ -> strP <* optional A.endOfLine
+        _ -> do
+          _day <- "dayMsgQueues=" *> strP <* A.endOfLine
+          _week <- "weekMsgQueues=" *> strP <* A.endOfLine
+          _month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
+          pure PeriodStatsData {_day, _week, _month}
+    _activeQueuesNtf <-
+      optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
+        Just _ -> strP <* optional A.endOfLine
+        _ -> pure newPeriodStatsData
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount = 0, _msgCount = 0}
 
 data PeriodStats a = PeriodStats
   { day :: TVar (Set a),
@@ -116,6 +153,10 @@ data PeriodStatsData a = PeriodStatsData
     _week :: Set a,
     _month :: Set a
   }
+  deriving (Show)
+
+newPeriodStatsData :: PeriodStatsData a
+newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty}
 
 getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
 getPeriodStatsData s = do
@@ -126,9 +167,9 @@ getPeriodStatsData s = do
 
 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)
+  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} =
@@ -165,4 +206,4 @@ updatePeriodStats stats pId = do
   updatePeriod week
   updatePeriod month
   where
-    updatePeriod pSel = modifyTVar (pSel stats) (S.insert pId)
+    updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)

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.3.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,5 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -8,7 +9,9 @@ module Simplex.Messaging.Transport.Client
     runTLSTransportClient,
     smpClientHandshake,
     defaultSMPPort,
+    defaultTransportClientConfig,
     defaultSocksProxy,
+    TransportClientConfig (..),
     SocksProxy,
     TransportHost (..),
     TransportHosts (..),
@@ -93,20 +96,31 @@ 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) => Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
-runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ socksProxy_ host port keyHash keepAliveOpts client = do
-  let clientParams = mkTLSClientParams tlsParams caStore_ (B.unpack $ strEncode host) port keyHash
-      connectTCP = case socksProxy_ of
-        Just proxy -> connectSocksClient proxy $ hostAddr host
-        _ -> connectTCPClient . B.unpack $ strEncode host
+runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
+runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} proxyUsername host port keyHash client = do
+  let hostName = B.unpack $ strEncode host
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
+      connectTCP = case socksProxy of
+        Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
+        _ -> connectTCPClient hostName
   c <- liftIO $ do
     sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) keepAliveOpts
-    connectTLS clientParams sock >>= getClientConnection
+    mapM_ (setSocketKeepAlive sock) tcpKeepAlive
+    connectTLS (Just hostName) logTLSErrors clientParams sock >>= getClientConnection
   client c `E.finally` liftIO (closeConnection c)
   where
     hostAddr = \case
@@ -139,10 +153,12 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
 defaultSMPPort :: PortNumber
 defaultSMPPort = 5223
 
-connectSocksClient :: SocksProxy -> SocksHostAddress -> ServiceName -> IO Socket
-connectSocksClient (SocksProxy addr) hostAddr _port = do
+connectSocksClient :: SocksProxy -> Maybe ByteString -> SocksHostAddress -> ServiceName -> IO Socket
+connectSocksClient (SocksProxy addr) proxyUsername hostAddr _port = do
   let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
-  fst <$> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
+  fst <$> case proxyUsername of
+    Just username -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) (SocksCredentials username "")
+    _ -> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
 
 defaultSocksHost :: HostAddress
 defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)

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 (TransportHost (..), 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 Nothing (THDomainName 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 Nothing (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/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
     }
 

tests/AgentTests.hs

@@ -78,6 +78,8 @@ 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
@@ -331,13 +333,13 @@ testServerConnectionAfterError t _ = do
 
   withAgent1 $ \bob -> do
     withAgent2 $ \alice -> do
-      bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER e)) -> e == NETWORK || e == TIMEOUT
-      alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER e)) -> e == NETWORK || e == TIMEOUT
+      bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
+      alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
       withServer $ do
         alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
         alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
-        bob <# ("", "", UP server ["alice"])
-        bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
+        bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
+        bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
         bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
         alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
         alice <# ("", "bob", SENT 5)
@@ -379,8 +381,8 @@ testMsgDeliveryAgentRestart t bob = do
           (corrId == "3" && cmd == OK)
             || (corrId == "" && cmd == SENT 5)
         _ -> False
-      bob <# ("", "", UP server ["alice"])
-      bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
+      bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
+      bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False
       bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
 
   removeFile testStoreLogFile
@@ -430,6 +432,32 @@ 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 T INV")

tests/AgentTests/FunctionalAPITests.hs

@@ -3,9 +3,11 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module AgentTests.FunctionalAPITests
@@ -14,6 +16,8 @@ module AgentTests.FunctionalAPITests
     makeConnection,
     exchangeGreetingsMsgId,
     switchComplete,
+    runRight,
+    runRight_,
     get,
     (##>),
     (=##>),
@@ -23,32 +27,39 @@ where
 
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad
-import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad.Except (ExceptT, runExceptT, throwError)
 import Control.Monad.IO.Unlift
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (isRight)
 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, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
+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.Agent.Store (UserId)
+import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), 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
 
-(##>) :: MonadIO m => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
+(##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
 a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
 
-(=##>) :: MonadIO m => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m ()
+(=##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m ()
 a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
 
 get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
@@ -74,6 +85,15 @@ agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11}
 vr11 :: VersionRange
 vr11 = mkVersionRange 1 1
 
+runRight_ :: HasCallStack => ExceptT AgentErrorType IO () -> Expectation
+runRight_ action = runExceptT action `shouldReturn` Right ()
+
+runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a
+runRight action =
+  runExceptT action >>= \case
+    Right x -> pure x
+    Left e -> error $ "Unexpected error: " <> show e
+
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
   describe "Establishing duplex connection" $
@@ -120,6 +140,17 @@ functionalAPITests t = do
       testAsyncCommandsRestore t
     it "should accept connection using async command" $
       withSmpServer t testAcceptContactAsync
+    it "should delete connections using async command when server connection fails" $
+      testDeleteConnectionAsync t
+  describe "Users" $ do
+    it "should create and delete user with connections" $
+      withSmpServer t testUsers
+    it "should create and delete user without connections" $
+      withSmpServer t testDeleteUserQuietly
+    it "should create and delete user with connections when server connection fails" $
+      testUsersNoServer t
+    it "should connect two users and switch session mode" $
+      withSmpServer t testTwoUsers
   describe "Queue rotation" $ do
     describe "should switch delivery to the new queue" $
       testServerMatrix2 t testSwitchConnection
@@ -127,6 +158,62 @@ functionalAPITests t = do
       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
+
+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
+
+canCreateQueue :: Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> Bool
+canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
+  allowNew && (isNothing srvAuth || (srvVersion == 5 && clntVersion == 5 && srvAuth == clntAuth))
 
 testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2 t runTest = do
@@ -153,11 +240,11 @@ runTestCfg2 aliceCfg bobCfg baseMsgId runTest = do
   bob <- getSMPAgentClient bobCfg {database = testDB2} initAgentServers
   runTest alice bob baseMsgId
 
-runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientTest alice bob baseId = do
-  Right () <- runExceptT $ do
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+  runRight_ $ do
+    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo"
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
@@ -185,15 +272,14 @@ runAgentClientTest alice bob baseId = do
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
     liftIO $ noMessages alice "nothing else should be delivered to alice"
-  pure ()
   where
     msgId = subtract baseId
 
-runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientContactTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientContactTest alice bob baseId = do
-  Right () <- runExceptT $ do
-    (_, qInfo) <- createConnection alice True SCMContact Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+  runRight_ $ do
+    (_, qInfo) <- createConnection alice 1 True SCMContact Nothing
+    aliceId <- joinConnection bob 1 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
@@ -223,26 +309,25 @@ runAgentClientContactTest alice bob baseId = do
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
     liftIO $ noMessages alice "nothing else should be delivered to alice"
-  pure ()
   where
     msgId = subtract baseId
 
-noMessages :: AgentClient -> String -> Expectation
+noMessages :: HasCallStack => AgentClient -> String -> Expectation
 noMessages c err = tryGet `shouldReturn` ()
   where
     tryGet =
       10000 `timeout` get c >>= \case
-        Just _ -> error err
+        Just msg -> error $ err <> ": " <> show msg
         _ -> return ()
 
-testAsyncInitiatingOffline :: IO ()
+testAsyncInitiatingOffline :: HasCallStack => IO ()
 testAsyncInitiatingOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
-    (bobId, cReq) <- createConnection alice True SCMInvitation Nothing
+  runRight_ $ do
+    (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     disconnectAgentClient alice
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
     ("", _, CONF confId _ "bob's connInfo") <- get alice'
@@ -251,15 +336,14 @@ testAsyncInitiatingOffline = do
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
     exchangeGreetings alice' bobId bob aliceId
-  pure ()
 
-testAsyncJoiningOfflineBeforeActivation :: IO ()
+testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO ()
 testAsyncJoiningOfflineBeforeActivation = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+  runRight_ $ do
+    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo"
     disconnectAgentClient bob
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
@@ -269,16 +353,15 @@ testAsyncJoiningOfflineBeforeActivation = do
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
     get bob' ##> ("", aliceId, CON)
     exchangeGreetings alice bobId bob' aliceId
-  pure ()
 
-testAsyncBothOffline :: IO ()
+testAsyncBothOffline :: HasCallStack => IO ()
 testAsyncBothOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
-    (bobId, cReq) <- createConnection alice True SCMInvitation Nothing
+  runRight_ $ do
+    (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     disconnectAgentClient alice
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     disconnectAgentClient bob
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
@@ -290,54 +373,51 @@ testAsyncBothOffline = do
     get bob' ##> ("", aliceId, INFO "alice's connInfo")
     get bob' ##> ("", aliceId, CON)
     exchangeGreetings alice' bobId bob' aliceId
-  pure ()
 
-testAsyncServerOffline :: ATransport -> IO ()
+testAsyncServerOffline :: HasCallStack => ATransport -> IO ()
 testAsyncServerOffline t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   -- create connection and shutdown the server
-  Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
-    runExceptT $ createConnection alice True SCMInvitation Nothing
+  (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
+    runRight $ createConnection alice 1 True SCMInvitation Nothing
   -- connection fails
-  Left (BROKER NETWORK) <- runExceptT $ joinConnection bob True cReq "bob's connInfo"
+  Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo"
   ("", "", DOWN srv conns) <- get alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
   -- connection succeeds after server start
-  Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
+  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
     ("", "", UP srv1 conns1) <- get alice
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
     exchangeGreetings alice bobId bob aliceId
-  pure ()
 
-testAsyncHelloTimeout :: IO ()
+testAsyncHelloTimeout :: HasCallStack => 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 {database = testDB2, helloTimeout = 1} initAgentServers
-  Right () <- runExceptT $ do
-    (_, cReq) <- createConnection alice True SCMInvitation Nothing
+  runRight_ $ do
+    (_, cReq) <- createConnection alice 1 True SCMInvitation Nothing
     disconnectAgentClient alice
-    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
-  pure ()
 
-testDuplicateMessage :: ATransport -> IO ()
+testDuplicateMessage :: HasCallStack => ATransport -> IO ()
 testDuplicateMessage t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
   (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
-    Right (aliceId, bobId) <- runExceptT $ makeConnection alice bob
-    Right () <- runExceptT $ do
+    (aliceId, bobId) <- runRight $ makeConnection alice bob
+    runRight_ $ do
       4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
       get alice ##> ("", bobId, SENT 4)
       get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
@@ -345,7 +425,7 @@ testDuplicateMessage t = do
 
     -- if the agent user did not send ACK, the message will be delivered again
     bob1 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-    Right () <- runExceptT $ do
+    runRight_ $ do
       subscribeConnection bob1 aliceId
       get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
       ackMessage bob1 aliceId 4
@@ -357,10 +437,10 @@ testDuplicateMessage t = do
 
   get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
   get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
-  -- commenting two lines below and uncommenting further two lines would also pass,
+  -- commenting two lines below and uncommenting further two lines would also runRight_,
   -- it is the scenario tested above, when the message was not acknowledged by the user
   threadDelay 200000
-  Left (BROKER TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
+  Left (BROKER _ TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
 
   disconnectAgentClient alice
   disconnectAgentClient bob1
@@ -369,7 +449,7 @@ testDuplicateMessage t = do
   bob2 <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
 
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
-    Right () <- runExceptT $ do
+    runRight_ $ do
       subscribeConnection bob2 aliceId
       subscribeConnection alice2 bobId
       -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
@@ -378,12 +458,14 @@ testDuplicateMessage t = do
       6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3"
       get alice2 ##> ("", bobId, SENT 6)
       get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
-    pure ()
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
-makeConnection alice bob = do
-  (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-  aliceId <- joinConnection bob True qInfo "bob's connInfo"
+makeConnection alice bob = makeConnectionForUsers alice 1 bob 1
+
+makeConnectionForUsers :: AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
+makeConnectionForUsers alice aliceUserId bob bobUserId = do
+  (bobId, qInfo) <- createConnection alice aliceUserId True SCMInvitation Nothing
+  aliceId <- joinConnection bob bobUserId True qInfo "bob's connInfo"
   ("", _, CONF confId _ "bob's connInfo") <- get alice
   allowConnection alice bobId confId "alice's connInfo"
   get alice ##> ("", bobId, CON)
@@ -396,10 +478,9 @@ testInactiveClientDisconnected t = do
   let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient agentCfg initAgentServers
-    Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice True SCMInvitation Nothing
+    runRight_ $ do
+      (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing
       get alice ##> ("", "", DOWN testSMPServer [connId])
-    pure ()
 
 testActiveClientNotDisconnected :: ATransport -> IO ()
 testActiveClientNotDisconnected t = do
@@ -407,10 +488,9 @@ testActiveClientNotDisconnected t = do
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient agentCfg initAgentServers
     ts <- getSystemTime
-    Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice True SCMInvitation Nothing
+    runRight_ $ do
+      (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing
       keepSubscribing alice connId ts
-    pure ()
   where
     keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO ()
     keepSubscribing alice connId ts = do
@@ -433,7 +513,7 @@ testSuspendingAgent :: IO ()
 testSuspendingAgent = do
   a <- getSMPAgentClient agentCfg initAgentServers
   b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
     get a ##> ("", bId, SENT 4)
@@ -446,13 +526,12 @@ testSuspendingAgent = do
     Nothing <- 100000 `timeout` get b
     activateAgent b
     get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
-  pure ()
 
 testSuspendingAgentCompleteSending :: ATransport -> IO ()
 testSuspendingAgentCompleteSending t = do
   a <- getSMPAgentClient agentCfg initAgentServers
   b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
+  (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
     get a ##> ("", bId, SENT 4)
@@ -460,7 +539,7 @@ testSuspendingAgentCompleteSending t = do
     ackMessage b aId 4
     pure (aId, bId)
 
-  Right () <- runExceptT $ do
+  runRight_ $ do
     ("", "", DOWN {}) <- get a
     ("", "", DOWN {}) <- get b
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
@@ -468,27 +547,23 @@ testSuspendingAgentCompleteSending t = do
     liftIO $ threadDelay 100000
     suspendAgent b 5000000
 
-  Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
+  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
     get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
     get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
     get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
     ("", "", SUSPENDED) <- get b
 
-    r <- get a
-    liftIO $ print r
-    ("", "", UP {}) <- pure r
-    get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
+    get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False
+    get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False
     ackMessage a bId 5
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
     ackMessage a bId 6
 
-  pure ()
-
 testSuspendingAgentTimeout :: ATransport -> IO ()
 testSuspendingAgentTimeout t = do
   a <- getSMPAgentClient agentCfg initAgentServers
   b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right (aId, _) <- withSmpServer t . runExceptT $ do
+  (aId, _) <- withSmpServer t . runRight $ do
     (aId, bId) <- makeConnection a b
     4 <- sendMessage a bId SMP.noMsgFlags "hello"
     get a ##> ("", bId, SENT 4)
@@ -496,7 +571,7 @@ testSuspendingAgentTimeout t = do
     ackMessage b aId 4
     pure (aId, bId)
 
-  Right () <- runExceptT $ do
+  runRight_ $ do
     ("", "", DOWN {}) <- get a
     ("", "", DOWN {}) <- get b
     5 <- sendMessage b aId SMP.noMsgFlags "hello too"
@@ -505,50 +580,64 @@ testSuspendingAgentTimeout t = do
     ("", "", SUSPENDED) <- get b
     pure ()
 
-  pure ()
-
 testBatchedSubscriptions :: ATransport -> IO ()
 testBatchedSubscriptions t = do
   a <- getSMPAgentClient agentCfg initAgentServers2
   b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers2
-  Right conns <- runServers $ do
+  conns <- runServers $ do
     conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
     forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
-    forM_ (take 10 conns) $ \(aId, bId) -> do
-      deleteConnection a bId
-      deleteConnection b aId
+    let (aIds', bIds') = unzip $ take 10 conns
+    delete a bIds'
+    delete b aIds'
     liftIO $ threadDelay 1000000
     pure conns
   ("", "", DOWN {}) <- get a
   ("", "", DOWN {}) <- get a
   ("", "", DOWN {}) <- get b
   ("", "", DOWN {}) <- get b
-  Right () <- runServers $ do
+  runServers $ do
     ("", "", UP {}) <- get a
     ("", "", UP {}) <- get a
     ("", "", UP {}) <- get b
     ("", "", UP {}) <- get b
     liftIO $ threadDelay 1000000
-    subscribe a $ map snd conns
-    subscribe b $ map fst conns
-    forM_ (drop 10 conns) $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
-  pure ()
+    let (aIds, bIds) = unzip conns
+        conns' = drop 10 conns
+        (aIds', bIds') = unzip conns'
+    subscribe a bIds
+    subscribe b aIds
+    forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
+    delete a bIds'
+    delete b aIds'
+    deleteFail a bIds'
+    deleteFail b aIds'
   where
     subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
     subscribe c cs = do
       r <- subscribeConnections c cs
       liftIO $ do
         let dc = S.fromList $ take 10 cs
-        all (== Right ()) (M.withoutKeys r dc) `shouldBe` True
+        all isRight (M.withoutKeys r dc) `shouldBe` True
         all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
         M.keys r `shouldMatchList` cs
-    runServers :: ExceptT AgentErrorType IO a -> IO (Either AgentErrorType a)
+    delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
+    delete c cs = do
+      r <- deleteConnections c cs
+      liftIO $ do
+        all isRight r `shouldBe` True
+        M.keys r `shouldMatchList` cs
+    deleteFail :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
+    deleteFail c cs = do
+      r <- deleteConnections c cs
+      liftIO $ do
+        all (== Left (CONN NOT_FOUND)) r `shouldBe` True
+        M.keys r `shouldMatchList` cs
+    runServers :: ExceptT AgentErrorType IO a -> IO a
     runServers a = do
       withSmpServerStoreLogOn t testPort $ \t1 -> do
-        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> do
-          res <- runExceptT a
-          killThread t2
-          pure res
+        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
+          runRight a `finally` killThread t2
         killThread t1
         pure res
 
@@ -556,11 +645,11 @@ testAsyncCommands :: IO ()
 testAsyncCommands = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
-    bobId <- createConnectionAsync alice "1" True SCMInvitation
+  runRight_ $ do
+    bobId <- createConnectionAsync alice 1 "1" True SCMInvitation
     ("1", bobId', INV (ACR _ qInfo)) <- get alice
     liftIO $ bobId' `shouldBe` bobId
-    aliceId <- joinConnectionAsync bob "2" True qInfo "bob's connInfo"
+    aliceId <- joinConnectionAsync bob 1 "2" True qInfo "bob's connInfo"
     ("2", aliceId', OK) <- get bob
     liftIO $ aliceId' `shouldBe` aliceId
     ("", _, CONF confId _ "bob's connInfo") <- get alice
@@ -590,10 +679,10 @@ testAsyncCommands = do
     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
+    deleteConnectionAsync alice bobId
+    get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False
+    get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False
     liftIO $ noMessages alice "nothing else should be delivered to alice"
-  pure ()
   where
     baseId = 3
     msgId = subtract baseId
@@ -601,24 +690,23 @@ testAsyncCommands = do
 testAsyncCommandsRestore :: ATransport -> IO ()
 testAsyncCommandsRestore t = do
   alice <- getSMPAgentClient agentCfg initAgentServers
-  Right bobId <- runExceptT $ createConnectionAsync alice "1" True SCMInvitation
+  bobId <- runRight $ createConnectionAsync alice 1 "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
+    runRight_ $ 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"
+  runRight_ $ do
+    (_, qInfo) <- createConnection alice 1 True SCMContact Nothing
+    aliceId <- joinConnection bob 1 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
@@ -650,22 +738,94 @@ testAcceptContactAsync = do
     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
 
+testDeleteConnectionAsync :: ATransport -> IO ()
+testDeleteConnectionAsync t = do
+  a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers
+  connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
+    (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing
+    (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing
+    (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing
+    pure ([bId1, bId2, bId3] :: [ConnId])
+  runRight_ $ do
+    deleteConnectionsAsync a connIds
+    get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
+    get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
+    get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False
+    get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False
+    get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False
+    get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False
+    liftIO $ noMessages a "nothing else should be delivered to alice"
+
+testUsers :: IO ()
+testUsers = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  runRight_ $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    auId <- createUser a [noAuthSrv testSMPServer]
+    (aId', bId') <- makeConnectionForUsers a auId b 1
+    exchangeGreetingsMsgId 4 a bId' b aId'
+    deleteUser a auId True
+    get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False
+    get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
+    get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
+    exchangeGreetingsMsgId 6 a bId b aId
+    liftIO $ noMessages a "nothing else should be delivered to alice"
+
+testDeleteUserQuietly :: IO ()
+testDeleteUserQuietly = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  runRight_ $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    auId <- createUser a [noAuthSrv testSMPServer]
+    (aId', bId') <- makeConnectionForUsers a auId b 1
+    exchangeGreetingsMsgId 4 a bId' b aId'
+    deleteUser a auId False
+    exchangeGreetingsMsgId 6 a bId b aId
+    liftIO $ noMessages a "nothing else should be delivered to alice"
+
+testUsersNoServer :: HasCallStack => ATransport -> IO ()
+testUsersNoServer t = do
+  a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetingsMsgId 4 a bId b aId
+    auId <- createUser a [noAuthSrv testSMPServer]
+    (aId', bId') <- makeConnectionForUsers a auId b 1
+    exchangeGreetingsMsgId 4 a bId' b aId'
+    pure (aId, bId, auId, aId', bId')
+  get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
+  get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
+  get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
+  runRight_ $ do
+    deleteUser a auId True
+    get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
+    get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
+    get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
+    liftIO $ noMessages a "nothing else should be delivered to alice"
+  withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
+    get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
+    get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
+    exchangeGreetingsMsgId 6 a bId b aId
+
 testSwitchConnection :: InitialAgentServers -> IO ()
 testSwitchConnection servers = do
   a <- getSMPAgentClient agentCfg servers
   b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
-  Right () <- runExceptT $ do
+  runRight_ $ 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
@@ -687,12 +847,12 @@ phase c connId d p =
       ERR (AGENT A_DUPLICATE) -> phase c connId d p
       r -> do
         liftIO . putStrLn $ "expected: " <> show p <> ", received: " <> show r
-        SWITCH _ _ _ <- pure r
+        SWITCH {} <- pure r
         pure ()
 
-testSwitchAsync :: InitialAgentServers -> IO ()
+testSwitchAsync :: HasCallStack => InitialAgentServers -> IO ()
 testSwitchAsync servers = do
-  Right (aId, bId) <- withA $ \a -> withB $ \b -> runExceptT $ do
+  (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
     pure (aId, bId)
@@ -707,22 +867,20 @@ testSwitchAsync servers = 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
+  withA $ \a -> withB $ \b -> runRight_ $ 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
+    session withC connId a =
+      withC $ \c -> runRight_ $ do
         subscribeConnection c connId
         r <- a c
         liftIO $ threadDelay 500000
         pure r
-      pure ()
     withA = withAgent agentCfg
     withB = withAgent agentCfg {database = testDB2, initialClientId = 1}
 
@@ -730,21 +888,132 @@ testSwitchDelete :: InitialAgentServers -> IO ()
 testSwitchDelete servers = do
   a <- getSMPAgentClient agentCfg servers
   b <- getSMPAgentClient agentCfg {database = testDB2, initialClientId = 1} servers
-  Right () <- runExceptT $ do
+  runRight_ $ 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 ()
+    deleteConnectionAsync a bId
+    get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
+    get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False
+    get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False
+    liftIO $ noMessages a "nothing else should be delivered to alice"
 
-exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
+testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
+testCreateQueueAuth clnt1 clnt2 = do
+  a <- getClient clnt1
+  b <- getClient clnt2
+  runRight $ do
+    tryError (createConnection a 1 True SCMInvitation Nothing) >>= \case
+      Left (SMP AUTH) -> pure 0
+      Left e -> throwError e
+      Right (bId, qInfo) ->
+        tryError (joinConnection b 1 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
+  where
+    getClient (clntAuth, clntVersion) =
+      let servers = initAgentServers {smp = userServers [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
+    runRight $ testSMPServerConnection a 1 srv
+
+testRatchetAdHash :: IO ()
+testRatchetAdHash = do
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  runRight_ $ do
+    (aId, bId) <- makeConnection a b
+    ad1 <- getConnectionRatchetAdHash a bId
+    ad2 <- getConnectionRatchetAdHash b aId
+    liftIO $ ad1 `shouldBe` ad2
+
+testTwoUsers :: HasCallStack => IO ()
+testTwoUsers = do
+  let nc = netCfg initAgentServers
+  a <- getSMPAgentClient agentCfg initAgentServers
+  b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
+  sessionMode nc `shouldBe` TSMUser
+  runRight_ $ do
+    (aId1, bId1) <- makeConnectionForUsers a 1 b 1
+    exchangeGreetings a bId1 b aId1
+    (aId1', bId1') <- makeConnectionForUsers a 1 b 1
+    exchangeGreetings a bId1' b aId1'
+    a `hasClients` 1
+    b `hasClients` 1
+    setNetworkConfig a nc {sessionMode = TSMEntity}
+    liftIO $ threadDelay 250000
+    ("", "", DOWN _ _) <- get a
+    ("", "", UP _ _) <- get a
+    a `hasClients` 2
+
+    exchangeGreetingsMsgId 6 a bId1 b aId1
+    exchangeGreetingsMsgId 6 a bId1' b aId1'
+    liftIO $ threadDelay 250000
+    setNetworkConfig a nc {sessionMode = TSMUser}
+    liftIO $ threadDelay 250000
+    ("", "", DOWN _ _) <- get a
+    ("", "", DOWN _ _) <- get a
+    ("", "", UP _ _) <- get a
+    ("", "", UP _ _) <- get a
+    a `hasClients` 1
+
+    aUserId2 <- createUser a [noAuthSrv testSMPServer]
+    (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1
+    exchangeGreetings a bId2 b aId2
+    (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1
+    exchangeGreetings a bId2' b aId2'
+    a `hasClients` 2
+    b `hasClients` 1
+    setNetworkConfig a nc {sessionMode = TSMEntity}
+    liftIO $ threadDelay 250000
+    ("", "", DOWN _ _) <- get a
+    ("", "", DOWN _ _) <- get a
+    ("", "", UP _ _) <- get a
+    ("", "", UP _ _) <- get a
+    a `hasClients` 4
+    exchangeGreetingsMsgId 8 a bId1 b aId1
+    exchangeGreetingsMsgId 8 a bId1' b aId1'
+    exchangeGreetingsMsgId 6 a bId2 b aId2
+    exchangeGreetingsMsgId 6 a bId2' b aId2'
+    liftIO $ threadDelay 250000
+    setNetworkConfig a nc {sessionMode = TSMUser}
+    liftIO $ threadDelay 250000
+    ("", "", DOWN _ _) <- get a
+    ("", "", DOWN _ _) <- get a
+    ("", "", DOWN _ _) <- get a
+    ("", "", DOWN _ _) <- get a
+    ("", "", UP _ _) <- get a
+    ("", "", UP _ _) <- get a
+    ("", "", UP _ _) <- get a
+    ("", "", UP _ _) <- get a
+    a `hasClients` 2
+    exchangeGreetingsMsgId 10 a bId1 b aId1
+    exchangeGreetingsMsgId 10 a bId1' b aId1'
+    exchangeGreetingsMsgId 8 a bId2 b aId2
+    exchangeGreetingsMsgId 8 a bId2' b aId2'
+  where
+    hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
+    hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
+
+exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetings = exchangeGreetingsMsgId 4
 
-exchangeGreetingsMsgId :: Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
+exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
 exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
   msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
   liftIO $ msgId1 `shouldBe` msgId

tests/AgentTests/NotificationTests.hs

@@ -8,7 +8,7 @@
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
+import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
 import Control.Concurrent (killThread, threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
@@ -91,7 +91,7 @@ notificationTests t =
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
@@ -105,7 +105,6 @@ testNotificationToken APNSMockServer {apnsQ} = do
     -- agent deleted this token
     Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
     pure ()
-  pure ()
 
 (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
 v .-> key = do
@@ -120,7 +119,7 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
   -- setLogLevel LogError -- LogDebug
   -- withGlobalLogging logCfg $ do
   a <- getSMPAgentClient agentCfg initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
@@ -138,7 +137,6 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
     verifyNtfToken a tkn nonce verification
     NTActive <- checkNtfToken a tkn
     pure ()
-  pure ()
 
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
@@ -146,7 +144,7 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
   -- withGlobalLogging logCfg $ do
   a <- getSMPAgentClient agentCfg initAgentServers
   a' <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     let tkn = DeviceToken PPApnsTest "abcd"
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
@@ -175,13 +173,12 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
     -- and the second is active
     NTActive <- checkNtfToken a' tkn
     pure ()
-  pure ()
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   a <- getSMPAgentClient agentCfg initAgentServers
   let tkn = DeviceToken PPApnsTest "abcd"
-  Right ntfData <- withNtfServer t . runExceptT $ do
+  ntfData <- withNtfServer t . runRight $ do
     NTRegistered <- registerNtfToken a tkn NMPeriodic
     APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
       atomically $ readTBQueue apnsQ
@@ -193,7 +190,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
   a' <- getSMPAgentClient agentCfg initAgentServers
   -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
   -- so that repeat verification happens without restarting the clients, when notification arrives
-  Right () <- withNtfServer t . runExceptT $ do
+  withNtfServer t . runRight_ $ do
     verification <- ntfData .-> "verification"
     nonce <- C.cbNonce <$> ntfData .-> "nonce"
     Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
@@ -205,16 +202,15 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
     verifyNtfToken a' tkn nonce' verification'
     NTActive <- checkNtfToken a' tkn
     pure ()
-  pure ()
 
 testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right (bobId, aliceId, nonce, message) <- runExceptT $ do
+  (bobId, aliceId, nonce, message) <- runRight $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
+    aliceId <- joinConnection bob 1 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")
@@ -243,12 +239,12 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
   aliceNtf <- getSMPAgentClient agentCfg initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
     pure ()
   disconnectAgentClient aliceNtf
 
-  Right () <- runExceptT $ do
+  runRight_ $ do
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
     -- delete notification subscription
@@ -259,7 +255,6 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     -- no notifications should follow
     noNotification apnsQ
-  pure ()
   where
     baseId = 3
     msgId = subtract baseId
@@ -268,16 +263,16 @@ testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
 testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     -- alice registers notification token
     DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
     -- bob registers notification token
     DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ
     -- establish connection
     liftIO $ threadDelay 50000
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
+    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
     liftIO $ threadDelay 1000000
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo"
     liftIO $ threadDelay 750000
     void $ messageNotification apnsQ
     ("", _, CONF confId _ "bob's connInfo") <- get alice
@@ -303,7 +298,6 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
     ackMessage bob aliceId $ baseId + 2
     -- no unexpected notifications should follow
     noNotification apnsQ
-  pure ()
   where
     baseId = 3
     msgId = subtract baseId
@@ -325,10 +319,10 @@ testChangeNotificationsMode :: APNSMockServer -> IO ()
 testChangeNotificationsMode APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
+    aliceId <- joinConnection bob 1 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")
@@ -381,7 +375,6 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     ackMessage alice bobId $ baseId + 5
     -- no notifications should follow
     noNotification apnsQ
-  pure ()
   where
     baseId = 3
     msgId = subtract baseId
@@ -390,10 +383,10 @@ testChangeToken :: APNSMockServer -> IO ()
 testChangeToken APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right (aliceId, bobId) <- runExceptT $ do
+  (aliceId, bobId) <- runRight $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice True SCMInvitation Nothing
-    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
+    aliceId <- joinConnection bob 1 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")
@@ -412,7 +405,7 @@ testChangeToken APNSMockServer {apnsQ} = do
   disconnectAgentClient alice
 
   alice1 <- getSMPAgentClient agentCfg initAgentServers
-  Right () <- runExceptT $ do
+  runRight_ $ do
     subscribeConnection alice1 bobId
     -- change notification token
     void $ registerTestToken alice1 "bcde" NMInstant apnsQ
@@ -425,7 +418,6 @@ testChangeToken APNSMockServer {apnsQ} = do
     ackMessage alice1 bobId $ baseId + 2
     -- no notifications should follow
     noNotification apnsQ
-  pure ()
   where
     baseId = 3
     msgId = subtract baseId
@@ -434,7 +426,7 @@ testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
 testNotificationsStoreLog t APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
+  (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
     liftIO $ threadDelay 250000
@@ -448,20 +440,19 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
 
   liftIO $ threadDelay 250000
 
-  Right () <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
+  withNtfServerStoreLog t $ \threadId -> runRight_ $ do
     liftIO $ threadDelay 250000
     5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT 5)
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     liftIO $ killThread threadId
-  pure ()
 
 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
-  Right (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
+  (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
     (aliceId, bobId) <- makeConnection alice bob
     _ <- registerTestToken alice "abcd" NMInstant apnsQ
     liftIO $ threadDelay 250000
@@ -473,11 +464,11 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     liftIO $ killThread threadId
     pure (aliceId, bobId)
 
-  Right () <- runExceptT $ do
+  runRight_ $ do
     get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
     get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
 
-  Right () <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
+  withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do
     get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
     get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
     liftIO $ threadDelay 1000000
@@ -486,13 +477,12 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     _ <- messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     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
+  runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
     _ <- registerTestToken a "abcd" NMInstant apnsQ
@@ -508,7 +498,6 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
     switchComplete a bId b aId
     liftIO $ threadDelay 500000
     testMessage "hello again"
-  pure ()
 
 messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apnsQ = do

tests/AgentTests/SQLiteTests.hs

@@ -140,7 +140,7 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False}
+cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, deleted = False}
 
 testPrivateSignKey :: C.APrivateSignKey
 testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -154,7 +154,8 @@ testDhSecret = "01234567890123456789012345678901"
 rcvQueue1 :: RcvQueue
 rcvQueue1 =
   RcvQueue
-    { connId = "conn1",
+    { userId = 1,
+      connId = "conn1",
       server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       rcvId = "1234",
       rcvPrivateKey = testPrivateSignKey,
@@ -167,13 +168,15 @@ rcvQueue1 =
       primary = True,
       dbReplaceQueueId = Nothing,
       smpClientVersion = 1,
-      clientNtfCreds = Nothing
+      clientNtfCreds = Nothing,
+      deleteErrors = 0
     }
 
 sndQueue1 :: SndQueue
 sndQueue1 =
   SndQueue
-    { connId = "conn1",
+    { userId = 1,
+      connId = "conn1",
       server = SMPServer "smp.simplex.im" "5223" testKeyHash,
       sndId = "3456",
       sndPublicKey = Nothing,
@@ -314,7 +317,8 @@ testUpgradeRcvConnToDuplex =
     _ <- createSndConn db g cData1 sndQueue1
     let anotherSndQueue =
           SndQueue
-            { connId = "conn1",
+            { userId = 1,
+              connId = "conn1",
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               sndId = "2345",
               sndPublicKey = Nothing,
@@ -340,7 +344,8 @@ testUpgradeSndConnToDuplex =
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     let anotherRcvQueue =
           RcvQueue
-            { connId = "conn1",
+            { userId = 1,
+              connId = "conn1",
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               rcvId = "3456",
               rcvPrivateKey = testPrivateSignKey,
@@ -353,7 +358,8 @@ testUpgradeSndConnToDuplex =
               primary = True,
               dbReplaceQueueId = Nothing,
               smpClientVersion = 1,
-              clientNtfCreds = Nothing
+              clientNtfCreds = Nothing,
+              deleteErrors = 0
             }
     upgradeSndConnToDuplex db "conn1" anotherRcvQueue
       `shouldReturn` Left (SEBadConnType CRcv)

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

@@ -1,18 +1,20 @@
 {-# 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
-import qualified Data.Text as T
-import qualified Data.ByteString.Char8 as B
-import Data.Text.Encoding (encodeUtf8)
 
 cryptoTests :: Spec
-cryptoTests = modifyMaxSuccess (const 10000) $ do
-  describe "padding / unpadding" $ do
+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
@@ -34,3 +36,37 @@ cryptoTests = modifyMaxSuccess (const 10000) $ do
     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 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 Simplex.Messaging.Protocol (ErrorType)
 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

@@ -44,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
@@ -70,7 +69,7 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
 testNtfClient client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
-  runTransportClient Nothing host ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+  runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
     liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -101,7 +100,8 @@ ntfServerCfg =
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/ntf-server-stats.daily.log",
-      serverStatsBackupFile = Nothing
+      serverStatsBackupFile = Nothing,
+      logTLSErrors = True
     }
 
 withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
@@ -178,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,6 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -11,7 +12,8 @@ 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 Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Network.Socket (ServiceName)
 import NtfClient (ntfTestPort)
 import SMPClient
@@ -27,11 +29,11 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
+import Simplex.Messaging.Agent.Store (UserId)
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
-import Simplex.Messaging.Transport.KeepAlive
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
@@ -174,13 +176,13 @@ testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5
 initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
-    { smp = L.fromList [testSMPServer],
+    { smp = userServers [noAuthSrv testSMPServer],
       ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
-      netCfg = defaultNetworkConfig {tcpTimeout = 500_000}
+      netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}
     }
 
 initAgentServers2 :: InitialAgentServers
-initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
+initAgentServers2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]}
 
 agentCfg :: AgentConfig
 agentCfg =
@@ -188,17 +190,8 @@ agentCfg =
     { tcpPort = agentTestPort,
       tbqSize = 4,
       database = testDB,
-      smpCfg =
-        defaultClientConfig
-          { qSize = 1,
-            defaultTransport = (testPort, transport @TLS),
-            networkConfig = defaultNetworkConfig {tcpTimeout = 500_000}
-          },
-      ntfCfg =
-        defaultClientConfig
-          { qSize = 1,
-            defaultTransport = (ntfTestPort, transport @TLS)
-          },
+      smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS)},
+      ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS)},
       reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
       ntfWorkerDelay = 1000,
       ntfSMPWorkerDelay = 1000,
@@ -210,11 +203,14 @@ agentCfg =
 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', database = db'}
-      initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
+      initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
    in serverBracket
         (\started -> runSMPAgentBlocking t started cfg' initServers')
         afterProcess
 
+userServers :: NonEmpty SMPServerWithAuth -> Map UserId (NonEmpty SMPServerWithAuth)
+userServers srvs = M.fromList [(1, srvs)]
+
 withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> (ThreadId -> m a) -> m a
 withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a $ removeFile (dbFile db')
 
@@ -227,7 +223,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
   Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost
-  runTransportClient Nothing useHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
+  runTransportClient defaultTransportClientConfig Nothing useHost port' (Just testKeyHash) $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
       then client h

tests/SMPClient.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -23,7 +24,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
@@ -58,7 +58,7 @@ testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
 testSMPClient client = do
   Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
-  runTransportClient Nothing useHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+  runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h ->
     liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -78,6 +78,7 @@ cfg =
       storeLogFile = Nothing,
       storeMsgsFile = Nothing,
       allowNewQueues = True,
+      newQueueBasicAuth = Nothing,
       messageExpiration = Just defaultMessageExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
@@ -87,28 +88,29 @@ cfg =
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
-      smpServerVRange = supportedSMPServerVRange
+      smpServerVRange = supportedSMPServerVRange,
+      logTLSErrors = True
     }
 
-withSmpServerStoreMsgLogOnV2 :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
+withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
 
-withSmpServerStoreMsgLogOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
+withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
-withSmpServerStoreLogOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
+withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
-withSmpServerConfigOn :: ATransport -> ServerConfig -> ServiceName -> (ThreadId -> IO a) -> IO a
+withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerConfigOn t cfg' port' =
   serverBracket
     (\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
     (pure ())
 
-withSmpServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
+withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerThreadOn t = withSmpServerConfigOn t cfg
 
-serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
+serverBracket :: (HasCallStack, MonadUnliftIO m) => (TMVar Bool -> m ()) -> m () -> (HasCallStack => ThreadId -> m a) -> m a
 serverBracket process afterProcess f = do
   started <- newEmptyTMVarIO
   E.bracket
@@ -121,16 +123,16 @@ serverBracket process afterProcess f = do
         Nothing -> error $ "server did not " <> s
         _ -> pure ()
 
-withSmpServerOn :: ATransport -> ServiceName -> IO a -> IO a
+withSmpServerOn :: HasCallStack => ATransport -> ServiceName -> IO a -> IO a
 withSmpServerOn t port' = withSmpServerThreadOn t port' . const
 
-withSmpServer :: ATransport -> IO a -> IO a
+withSmpServer :: HasCallStack => ATransport -> IO a -> IO a
 withSmpServer t = withSmpServerOn t testPort
 
-runSmpTest :: forall c a. Transport c => (THandle c -> IO a) -> IO a
+runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandle c -> IO a) -> IO a
 runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
 
-runSmpTestN :: forall c a. Transport c => Int -> ([THandle c] -> IO a) -> IO a
+runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO a) -> IO a
 runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
   where
     run :: Int -> [THandle c] -> IO a
@@ -153,25 +155,25 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
-smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
+smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> IO ()) -> Expectation
 smpTest _ test' = runSmpTest test' `shouldReturn` ()
 
-smpTestN :: Transport c => Int -> ([THandle c] -> IO ()) -> Expectation
+smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO ()) -> Expectation
 smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
 
-smpTest2 :: Transport c => TProxy c -> (THandle c -> THandle c -> IO ()) -> Expectation
+smpTest2 :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation
 smpTest2 _ test' = smpTestN 2 _test
   where
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpTest3 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
+smpTest3 :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
 smpTest3 _ test' = smpTestN 3 _test
   where
     _test [h1, h2, h3] = test' h1 h2 h3
     _test _ = error "expected 3 handles"
 
-smpTest4 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
+smpTest4 :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
 smpTest4 _ test' = smpTestN 4 _test
   where
     _test [h1, h2, h3, h4] = test' h1 h2 h3 h4

tests/ServerTests.hs

@@ -11,15 +11,17 @@
 
 module ServerTests where
 
+import AgentTests.NotificationTests (removeFileIfExists)
 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
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.Set as S
 import SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -28,6 +30,7 @@ import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
 import Simplex.Messaging.Transport
 import System.Directory (removeFile)
 import System.TimeIt (timeItT)
@@ -49,9 +52,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 +81,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 +107,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 +119,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"
 
@@ -178,7 +183,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"
 
@@ -242,7 +247,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"
 
@@ -313,7 +318,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)
@@ -330,7 +335,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
@@ -339,7 +344,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
 
@@ -355,7 +360,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
@@ -393,7 +398,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"
@@ -494,6 +499,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
@@ -577,6 +608,10 @@ logSize f =
 testRestoreMessages :: ATransport -> Spec
 testRestoreMessages at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
+    removeFileIfExists testStoreLogFile
+    removeFileIfExists testStoreMsgsFile
+    removeFileIfExists testServerStatsBackupFile
+
     (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
     recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
@@ -600,13 +635,19 @@ 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 ()
 
+    rId <- readTVarIO recipientId
+
     logSize testStoreLogFile `shouldReturn` 2
-    logSize testStoreMsgsFile `shouldReturn` 3
+    logSize testStoreMsgsFile `shouldReturn` 5
+    logSize testServerStatsBackupFile `shouldReturn` 16
+    Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
+    checkStats stats1 [rId] 5 1
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
-      rId <- readTVarIO recipientId
       Just rKey <- readTVarIO recipientKey
       Just dh <- readTVarIO dhShared
       let dec = decryptMsgV3 dh
@@ -619,21 +660,33 @@ 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
+    logSize testServerStatsBackupFile `shouldReturn` 16
+    Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
+    checkStats stats2 [rId] 5 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
+    logSize testServerStatsBackupFile `shouldReturn` 16
+    Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
+    checkStats stats3 [rId] 5 5
 
     removeFile testStoreLogFile
     removeFile testStoreMsgsFile
+    removeFile testServerStatsBackupFile
   where
     runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
     runTest _ test' server = do
@@ -643,6 +696,20 @@ testRestoreMessages at@(ATransport t) =
     runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
     runClient _ test' = testSMPClient test' `shouldReturn` ()
 
+checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
+checkStats s qs sent received = do
+  _qCreated s `shouldBe` length qs
+  _qSecured s `shouldBe` length qs
+  _qDeleted s `shouldBe` 0
+  _msgSent s `shouldBe` sent
+  _msgRecv s `shouldBe` received
+  _msgSentNtf s `shouldBe` 0
+  _msgRecvNtf s `shouldBe` 0
+  let PeriodStatsData {_day, _week, _month} = _activeQueues s
+  S.toList _day `shouldBe` qs
+  S.toList _week `shouldBe` qs
+  S.toList _month `shouldBe` qs
+
 testRestoreMessagesV2 :: ATransport -> Spec
 testRestoreMessagesV2 at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
@@ -716,7 +783,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"
@@ -741,7 +808,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,10 +1,12 @@
 {-# LANGUAGE TypeApplications #-}
 
 import AgentTests (agentTests)
--- import Control.Logger.Simple
+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
@@ -14,24 +16,27 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import Test.Hspec
 
--- logCfg :: LogConfig
--- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
-  -- setLogLevel LogInfo -- LogError
-  -- 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 "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
+    setEnv "APNS_KEY_ID" "H82WD9K9AQ"
+    setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
+    hspec
+      . before_ (createDirectoryIfMissing False "tests/tmp")
+      . after_ (removeDirectoryRecursive "tests/tmp")
+      $ 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