delivery to non-current queues

* refactor agent subscriptions with TMap2

* refactor

* refactor

* comment

.gitignore

@@ -4,3 +4,5 @@
 *.session.sql
 tests/tmp
 dist-newstyle/
+
+src/tor

CHANGELOG.md

@@ -1,3 +1,17 @@
+# 3.2.0
+
+SMP agent:
+
+- Support multiple server hostnames (including onion hostnames) in server addresses.
+- Network configuration options.
+- Options to define rules to choose server hostname.
+
+# 3.1.0
+
+SMP server and agent:
+
+- SMP protocol v4: batching multiple server commands/responses in a transport block.
+
 # 3.0.0
 
 SMP server:

README.md

@@ -11,7 +11,7 @@ If you have a server deployed please deploy a new server to a new host and retir
 
 ## Message broker for unidirectional (simplex) queues
 
-SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
+SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](./protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](./protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
 
 SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.
 
@@ -27,7 +27,7 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
 
 ### SMP server
 
-[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
+[SMP server](./apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
 
 To initialize the server use `smp-server init -n <fqdn>` (or `smp-server init --ip <ip>` for IP based address) command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
 
@@ -39,7 +39,7 @@ Starting from version 2.3.0, when store log is enabled, the server would also en
 
 > **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
 
-SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
+SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
 
 #### Running SMP server on MacOS
 
@@ -62,7 +62,7 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP client library
 
-[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
+[SMP client](./src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
 
 - execute commands with a functional API.
 - receive messages and other notifications via STM queue.
@@ -70,13 +70,13 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
 
 ### SMP agent
 
-[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
+[SMP agent library](./src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
 
-Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
+Haskell type [ACommand](./src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
 
 See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
 
-[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
+[SMP agent executable](./apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](./protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
 
 ## Using SMP server and SMP agent
 
@@ -110,7 +110,15 @@ 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="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
+<img alt="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
 
@@ -134,7 +142,7 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
 
 Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
 
-[<img alt="DigitalOcean" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
+[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
 
 ## Deploy SMP server on DigitalOcean
 
@@ -162,12 +170,12 @@ smp-server init [-l] -n <fqdn>
 
 ## SMP server design
 
-![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
+![SMP server design](./design/server.svg)
 
 ## SMP agent design
 
-![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
+![SMP agent design](./design/agent2.svg)
 
 ## License
 
-[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)
+[AGPL v3](./LICENSE)

apps/ntf-server/Main.hs

@@ -1,9 +1,12 @@
 {-# 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 (..))
@@ -42,7 +45,7 @@ ntfServerCLIConfig =
           fingerprintFile = combine cfgPath "fingerprint",
           defaultServerPort = "443",
           executableName = "ntf-server",
-          serverVersion = "SMP notifications server v1.0.0",
+          serverVersion = "SMP notifications server v1.2.0",
           mkIniFile = \enableStoreLog defaultServerPort ->
             "[STORE_LOG]\n\
             \# The server uses STM memory for persistence,\n\
@@ -50,28 +53,36 @@ ntfServerCLIConfig =
             \# This option enables saving memory to append only log,\n\
             \# and restoring it when the server is started.\n\
             \# Log is compacted on start (deleted objects are removed).\n\
-            \# The messages are not logged.\n"
-              <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n\n")
-              <> "[TRANSPORT]\n\
+            \enable: "
+              <> (if enableStoreLog then "on" else "off")
+              <> "\n\
+                 \log_stats: off\n\n\
+                 \[TRANSPORT]\n\
                  \port: "
               <> defaultServerPort
               <> "\n\
                  \websockets: off\n",
-          mkServerConfig = \storeLogFile transports _ ->
-            NtfServerConfig
-              { transports,
-                subIdBytes = 24,
-                regCodeBytes = 32,
-                clientQSize = 16,
-                subQSize = 64,
-                pushQSize = 128,
-                smpAgentCfg = defaultSMPClientAgentConfig,
-                apnsConfig = defaultAPNSPushClientConfig,
-                inactiveClientExpiration = Nothing,
-                storeLogFile,
-                resubscribeDelay = 50000, -- 50ms
-                caCertificateFile = caCrtFile,
-                privateKeyFile = serverKeyFile,
-                certificateFile = serverCrtFile
-              }
+          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"
+                  }
         }

apps/smp-agent/Main.hs

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

apps/smp-server/Main.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Main where
 
@@ -60,9 +59,10 @@ smpServerCLIConfig =
             \# and restoring it when the server is started.\n\
             \# Log is compacted on start (deleted objects are removed).\n"
               <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n")
-              <> "# The messages are optionally saved and restored when the server restarts,\n\
-                 \# they are deleted after restarting.\n"
-              <> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n\n")
+              <> "# 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"
@@ -72,38 +72,38 @@ smpServerCLIConfig =
               <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
               <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
           mkServerConfig = \storeLogFile transports ini ->
-            ServerConfig
-              { transports,
-                tbqSize = 16,
-                serverTbqSize = 64,
-                msgQueueQuota = 128,
-                queueIdBytes = 24,
-                msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
-                caCertificateFile = caCrtFile,
-                privateKeyFile = serverKeyFile,
-                certificateFile = serverCrtFile,
-                storeLogFile,
-                storeMsgsFile =
-                  let messagesPath = combine logPath "smp-server-messages.log"
-                   in case lookupValue "STORE_LOG" "restore_messages" ini of
-                        Right "on" -> Just messagesPath
-                        Right _ -> Nothing
-                        -- if the setting is not set, it is enabled when store log is enabled
-                        _ -> storeLogFile $> messagesPath,
-                allowNewQueues = True,
-                messageExpiration = Just defaultMessageExpiration,
-                inactiveClientExpiration =
-                  if lookupValue "INACTIVE_CLIENTS" "disconnect" ini == Right "on"
-                    then
-                      Just
-                        ExpirationConfig
+            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
-                          }
-                    else Nothing,
-                logStatsInterval = Just 86400, -- seconds
-                logStatsStartTime = 0, -- seconds from 00:00 UTC
-                serverStatsFile = Just $ combine logPath "smp-server-stats.log",
-                smpServerVRange = supportedSMPServerVRange
-              }
+                          },
+                    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
+                  }
         }

img/linode.svg

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

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 3.0.0
+version: 3.2.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -49,12 +49,13 @@ dependencies:
   - memory == 0.15.*
   - mtl == 2.2.*
   - network >= 3.1.2.7 && < 3.2
-  - network-transport == 0.5.*
+  - network-transport == 0.5.4
   - optparse-applicative >= 0.15 && < 0.17
   - QuickCheck == 2.14.*
   - process == 1.6.*
   - random >= 1.1 && < 1.3
   - simple-logger == 0.1.*
+  - socks == 0.6.*
   - sqlite-simple == 0.4.*
   - stm == 2.5.*
   - template-haskell == 2.16.*
@@ -62,7 +63,7 @@ dependencies:
   - time == 1.9.*
   - time-compat == 1.9.*
   - time-manager == 0.0.*
-  - tls >= 1.5.7 && < 1.6
+  - tls >= 1.6.0 && < 1.7
   - transformers == 0.5.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*

protocol/simplex-messaging.md

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

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

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

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

@@ -0,0 +1,57 @@
+# SMP queue rotation
+
+## Problem
+
+1. Long term usage of the queue allows the servers to analyse long term traffic patterns.
+
+2. If the user changes the configured SMP server(s), the previously created contacts do not migrate to the new server(s).
+
+## Solution
+
+Additional messages exchanged by SMP agents to negotiate migration of the queues to the new server. I considered combining this with queue redundancy, but it increases scope and adds a lot of complexity before it is needed.
+
+The proposed approach separates queue rotation from any queue redundancy that may be added in the future.
+
+### Messages
+
+Additional agent messages required for the protocol:
+
+`QNEW`: notify the sender that the queue has to be rotated to the new one, includes the address (server, sender ID and DH key) of the new queue. Encoded as `QN`.
+
+`QKEYS`: pass sender's server key and DH key via existing connection (SMP confirmation message will not be used, to avoid the same "race" of the initial key exchange that would create the risk of intercepting the queue for the attacker), encoded as `QK`.
+
+`QREADY`: instruct the sender that the new is ready to use with sender's queue address as parameter, encoded as `QR` - sender will send HELLO to the new queue.
+
+`QTEST`: sender sends to the new queue to confirm it's working, encoded as `QT`
+
+`QSWITCH`: instruct the sender to use the new queue with sender's queue ID as parameter, encoded as `QS` - sent after receiving `QTEST`.
+
+`QHELLO`: sender sends to the new queue to confirm switch was successful - all new messages after this message will be sent to the new queue. Encoded as `QH`
+
+### Protocol
+
+```
+participant A as Alice
+participant B as Bob
+participant R as Server that has A's receive queue
+participant S as Server that has A's send queue (B's receive queue)
+participant R' as Server that hosts the new A's receive queue
+
+A ->> R': create new queue
+A ->> S ->> B: QNEW (R'): address of the new queue
+B ->> R ->> A: QKEYS (R'): sender's key for the new queue (to avoid the race of SMP confirmation for the initial exchange)
+B ->> R ->> A: continue sending new messages to the old queue
+A ->> R': secure queue
+A ->> S ->> B: QREADY (R'): notify sender that the queue is secured
+B ->> R' ->> A: QTEST: to validate that the sender can send messages to the new queue before switching to it
+A ->> S ->> B: QSWITCH (R'): instruction to start using the new queue
+B ->> R' ->> A: QHELLO: to confirm that the delivery is now switched to the new queue
+B ->> R' ->> A: the first message received to the new queue before the old one is drained and deleted should not be processed, it should be stored in the agent memory (and not acknowledged) and only processed once the old queue is drained.
+A ->> R: suspend queue, receive all messages
+A ->> R: delete queue
+```
+
+It will also require extending SMP protocol:
+
+- add message flag / meta-data indicating that this is the last message and the server has no more messages available (so that the recipient knows when it's safe to delete the queue). Alternatively it can be NUL message that is sent after the last suspended message is received and in response to OFF command.
+- when queue is suspended the server should return the remaining message count. It should be ok to suspend the queue again, so that if the agent is restarted and the queue status is suspended it can be suspended again to check the number of remaining messages.

scripts/docker/README.md

@@ -0,0 +1,25 @@
+# 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

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

scripts/docker/entrypoint

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

scripts/docker/logs/README.md

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

scripts/docker/smp-server-build.Dockerfile

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

scripts/docker/smp-server-download.Dockerfile

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

scripts/ntf-server-linode.sh

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

scripts/smp-server-linode.sh

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

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        3.0.0
+version:        3.2.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -50,6 +50,10 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220822_queue_rotation
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
       Simplex.Messaging.Crypto
@@ -61,6 +65,7 @@ library
       Simplex.Messaging.Notifications.Server
       Simplex.Messaging.Notifications.Server.Env
       Simplex.Messaging.Notifications.Server.Push.APNS
+      Simplex.Messaging.Notifications.Server.Stats
       Simplex.Messaging.Notifications.Server.Store
       Simplex.Messaging.Notifications.Server.StoreLog
       Simplex.Messaging.Notifications.Transport
@@ -78,6 +83,7 @@ library
       Simplex.Messaging.Server.Stats
       Simplex.Messaging.Server.StoreLog
       Simplex.Messaging.TMap
+      Simplex.Messaging.TMap2
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Client
       Simplex.Messaging.Transport.HTTP2
@@ -122,11 +128,12 @@ library
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -134,7 +141,7 @@ library
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -182,12 +189,13 @@ executable ntf-server
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -195,7 +203,7 @@ executable ntf-server
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -243,12 +251,13 @@ executable smp-agent
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -256,7 +265,7 @@ executable smp-agent
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -304,12 +313,13 @@ executable smp-server
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -317,7 +327,7 @@ executable smp-server
     , time ==1.9.*
     , time-compat ==1.9.*
     , time-manager ==0.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -384,12 +394,13 @@ test-suite smp-server-test
     , memory ==0.15.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
-    , network-transport ==0.5.*
+    , network-transport ==0.5.4
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplexmq
+    , socks ==0.6.*
     , sqlite-simple ==0.4.*
     , stm ==2.5.*
     , template-haskell ==2.16.*
@@ -398,7 +409,7 @@ test-suite smp-server-test
     , time-compat ==1.9.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.5.7 && <1.6
+    , tls >=1.6.0 && <1.7
     , transformers ==0.5.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*

src/Simplex/Messaging/Agent/Client.hs

@@ -16,18 +16,21 @@
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
+    MsgDeliveryKey,
     newAgentClient,
     withAgentLock,
     closeAgentClient,
+    closeProtocolServerClients,
     newRcvQueue,
     subscribeQueue,
+    subscribeQueues,
     getQueueMessage,
     decryptSMPMessage,
     addSubscription,
     getSubscriptions,
     sendConfirmation,
     sendInvitation,
-    RetryInterval (..),
+    temporaryAgentError,
     secureQueue,
     enableQueueNotifications,
     disableQueueNotifications,
@@ -64,6 +67,7 @@ module Simplex.Messaging.Agent.Client
     whenSuspending,
     withStore,
     withStore',
+    storeError,
   )
 where
 
@@ -74,16 +78,20 @@ import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Data.Bifunctor (first)
+import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Either (partitionEithers)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (catMaybes)
+import Data.Maybe (listToMaybe)
 import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text.Encoding
+import Data.Time.Clock (getCurrentTime)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
 import Simplex.Messaging.Agent.Env.SQLite
@@ -95,18 +103,42 @@ import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, NtfServer, ProtoServer, ProtocolServer (..), QueueId, QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, SMPMsgMeta (..), SndPublicVerifyKey)
+import Simplex.Messaging.Protocol
+  ( AProtocolType (..),
+    BrokerMsg,
+    ErrorType,
+    MsgFlags (..),
+    MsgId,
+    NotifierId,
+    NtfPrivateSignKey,
+    NtfPublicVerifyKey,
+    NtfServer,
+    ProtoServer,
+    Protocol (..),
+    ProtocolServer (..),
+    ProtocolTypeI (..),
+    QueueId,
+    QueueIdsKeys (..),
+    RcvMessage (..),
+    RcvNtfPublicDhKey,
+    SMPMsgMeta (..),
+    SndPublicVerifyKey,
+  )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (bshow, catchAll_, ifM, liftEitherError, liftError, tryError, unlessM, whenM)
+import Simplex.Messaging.TMap2 (TMap2)
+import qualified Simplex.Messaging.TMap2 as TM2
+import Simplex.Messaging.Transport.Client (TransportHost)
+import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Timeout (timeout)
-import UnliftIO (async, pooledForConcurrentlyN)
+import UnliftIO (async)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -116,6 +148,8 @@ type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
 
 type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
 
+type MsgDeliveryKey = (SMPServer, SMP.SenderId)
+
 data AgentClient = AgentClient
   { active :: TVar Bool,
     rcvQ :: TBQueue (ATransmission 'Client),
@@ -125,12 +159,18 @@ data AgentClient = AgentClient
     smpClients :: TMap SMPServer SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfServer NtfClientVar,
-    subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
-    pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
-    subscrConns :: TMap ConnId SMPServer,
-    connMsgsQueued :: TMap ConnId Bool,
-    smpQueueMsgQueues :: TMap (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId),
-    smpQueueMsgDeliveries :: TMap (ConnId, SMPServer, SMP.SenderId) (Async ()),
+    useNetworkConfig :: TVar NetworkConfig,
+    subscrConns :: TVar (Set ConnId),
+    -- Bool in tuple keys shows whether the queue is the current one (True) or the one the connection switches to (False)
+    activeSubs :: TMap2 SMPServer (ConnId, Bool) RcvQueue,
+    pendingSubs :: TMap2 SMPServer (ConnId, Bool) RcvQueue,
+    connMsgsQueued :: TVar (Set (ConnId, Bool)),
+    smpQueueMsgQueues :: TMap MsgDeliveryKey (TQueue InternalId),
+    smpQueueMsgDeliveries :: TMap MsgDeliveryKey (Async ()),
+    nextRcvQueueMsgs :: TMap (SMPServer, SMP.RecipientId) [ServerTransmission BrokerMsg],
+    connCmdsQueued :: TMap ConnId Bool,
+    asyncCmdQueues :: TMap (Maybe SMPServer) (TQueue AsyncCmdId),
+    asyncCmdProcesses :: TMap (Maybe SMPServer) (Async ()),
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -165,7 +205,7 @@ data AgentState = ASActive | ASSuspending | ASSuspended
   deriving (Eq, Show)
 
 newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
-newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
+newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
   active <- newTVar True
   rcvQ <- newTBQueue qSize
@@ -175,12 +215,17 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   smpClients <- TM.empty
   ntfServers <- newTVar ntf
   ntfClients <- TM.empty
-  subscrSrvrs <- TM.empty
-  pendingSubscrSrvrs <- TM.empty
-  subscrConns <- TM.empty
-  connMsgsQueued <- TM.empty
+  useNetworkConfig <- newTVar netCfg
+  subscrConns <- newTVar S.empty
+  activeSubs <- TM2.empty
+  pendingSubs <- TM2.empty
+  connMsgsQueued <- newTVar S.empty
   smpQueueMsgQueues <- TM.empty
   smpQueueMsgDeliveries <- TM.empty
+  nextRcvQueueMsgs <- TM.empty
+  connCmdsQueued <- TM.empty
+  asyncCmdQueues <- TM.empty
+  asyncCmdProcesses <- TM.empty
   ntfNetworkOp <- newTVar $ AgentOpState False 0
   rcvNetworkOp <- newTVar $ AgentOpState False 0
   msgDeliveryOp <- newTVar $ AgentOpState False 0
@@ -192,7 +237,7 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   asyncClients <- newTVar []
   clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
   lock <- newTMVar ()
-  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
+  return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useNetworkConfig, subscrConns, activeSubs, pendingSubs, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, nextRcvQueueMsgs, connCmdsQueued, asyncCmdQueues, asyncCmdProcesses, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
 
 agentDbPath :: AgentClient -> FilePath
 agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
@@ -215,84 +260,64 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
   atomically (getClientVar srv smpClients)
     >>= either
       (newProtocolClient c srv smpClients connectClient reconnectClient)
-      (waitForProtocolClient smpCfg)
+      (waitForProtocolClient c)
   where
     connectClient :: m SMPClient
     connectClient = do
-      cfg <- asks $ smpCfg . config
+      cfg <- atomically . updateClientConfig c =<< asks (smpCfg . config)
       u <- askUnliftIO
       liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
 
-    clientDisconnected :: UnliftIO m -> IO ()
-    clientDisconnected u = do
-      removeClientAndSubs >>= (`forM_` serverDown u)
+    clientDisconnected :: UnliftIO m -> SMPClient -> IO ()
+    clientDisconnected u client = do
+      removeClientAndSubs >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
-
-    removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
-    removeClientAndSubs = atomically $ do
-      TM.delete srv smpClients
-      TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
       where
-        updateSubs cVar = do
-          cs <- readTVar cVar
-          modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
-          addPendingSubs cVar cs
-          pure cs
+        removeClientAndSubs :: IO (Maybe (Map (ConnId, Bool) RcvQueue))
+        removeClientAndSubs = atomically $ do
+          TM.delete srv smpClients
+          TM2.lookupDelete1 srv (activeSubs c) >>= mapM updateSubs
+          where
+            updateSubs cVar = do
+              TM2.insert1 srv cVar $ pendingSubs c
+              readTVar cVar
 
-        addPendingSubs cVar cs = do
-          let ps = pendingSubscrSrvrs c
-          TM.lookup srv ps >>= \case
-            Just v -> TM.union cs v
-            _ -> TM.insert srv cVar ps
+        serverDown :: Map (ConnId, Bool) RcvQueue -> IO ()
+        serverDown cs = whenM (readTVarIO active) $ do
+          notifySub "" $ hostEvent DISCONNECT client
+          let conns = map fst . filter snd $ M.keys cs
+          unless (null conns) $ notifySub "" $ DOWN srv conns
+          unless (null cs) $ do
+            atomically $ mapM_ (releaseGetLock c) cs
+            unliftIO u reconnectServer
 
-    serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
-    serverDown u cs = unless (M.null cs) $
-      whenM (readTVarIO active) $ do
-        let conns = M.keys cs
-        unless (null conns) . notifySub "" $ DOWN srv conns
-        atomically $ mapM_ (releaseGetLock c) cs
-        unliftIO u reconnectServer
+        reconnectServer :: m ()
+        reconnectServer = do
+          a <- async tryReconnectClient
+          atomically $ modifyTVar' (reconnections c) (a :)
 
-    reconnectServer :: m ()
-    reconnectServer = do
-      a <- async tryReconnectClient
-      atomically $ modifyTVar' (reconnections c) (a :)
-
-    tryReconnectClient :: m ()
-    tryReconnectClient = do
-      ri <- asks $ reconnectInterval . config
-      withRetryInterval ri $ \loop ->
-        reconnectClient `catchError` const loop
+        tryReconnectClient :: m ()
+        tryReconnectClient = do
+          ri <- asks $ reconnectInterval . config
+          withRetryInterval ri $ \loop ->
+            reconnectClient `catchError` const loop
 
     reconnectClient :: m ()
-    reconnectClient = do
-      n <- asks $ resubscriptionConcurrency . config
-      withAgentLock c . withClient c srv $ \smp -> do
-        cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSubscrSrvrs c)
-        -- TODO if any of the subscriptions fails here (e.g. because of timeout), it terminates the whole process for all subscriptions
-        -- instead it should only report successful subscriptions and schedule the next call to reconnectClient to subscribe for the remaining subscriptions
-        -- this way, for each DOWN event there can be several UP events
-        conns <- pooledForConcurrentlyN n (maybe [] M.toList cs) $ \sub@(connId, _) ->
-          ifM
-            (atomically $ hasActiveSubscription c connId)
-            (pure $ Just connId)
-            (subscribe_ smp sub `catchError` handleError connId)
-        liftIO . unless (null conns) . notifySub "" . UP srv $ catMaybes conns
+    reconnectClient =
+      withAgentLock c $
+        atomically (TM2.lookup1 srv (pendingSubs c) >>= mapM readTVar)
+          >>= mapM_ resubscribe
       where
-        subscribe_ :: SMPClient -> (ConnId, RcvQueue) -> ExceptT ProtocolClientError IO (Maybe ConnId)
-        subscribe_ smp (connId, rq@RcvQueue {rcvPrivateKey, rcvId}) = do
-          subscribeSMPQueue smp rcvPrivateKey rcvId
-          addSubscription c rq connId
-          pure $ Just connId
-
-        handleError :: ConnId -> ProtocolClientError -> ExceptT ProtocolClientError IO (Maybe ConnId)
-        handleError connId = \case
-          e@PCEResponseTimeout -> throwError e
-          e@PCENetworkError -> throwError e
-          e -> do
-            liftIO . notifySub connId . ERR $ protocolClientError SMP e
-            atomically $ removePendingSubscription c srv connId
-            pure Nothing
+        resubscribe :: Map (ConnId, Bool) RcvQueue -> m ()
+        resubscribe qs = do
+          (client_, (errs, oks)) <- second (M.mapEither id) <$> subscribeQueues c srv qs
+          liftIO $ do
+            mapM_ (notifySub "" . hostEvent CONNECT) client_
+            let conns = map fst . filter snd $ M.keys oks
+            unless (null conns) $ notifySub "" $ UP srv conns
+          let (tempErrs, finalErrs) = M.partition temporaryAgentError errs
+          liftIO . mapM_ (\((connId, current), e) -> when current . notifySub connId $ ERR e) $ M.assocs finalErrs
+          mapM_ throwError . listToMaybe $ M.elems tempErrs
 
     notifySub :: ConnId -> ACommand 'Agent -> IO ()
     notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
@@ -303,16 +328,17 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
   atomically (getClientVar srv ntfClients)
     >>= either
       (newProtocolClient c srv ntfClients connectClient $ pure ())
-      (waitForProtocolClient ntfCfg)
+      (waitForProtocolClient c)
   where
     connectClient :: m NtfClient
     connectClient = do
-      cfg <- asks $ ntfCfg . config
+      cfg <- atomically . updateClientConfig c =<< asks (ntfCfg . config)
       liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: NtfClient -> IO ()
+    clientDisconnected client = do
       atomically $ TM.delete srv ntfClients
+      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))
@@ -324,10 +350,10 @@ getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.l
       TM.insert srv var clients
       pure var
 
-waitForProtocolClient :: AgentMonad m => (AgentConfig -> ProtocolClientConfig) -> ClientVar msg -> m (ProtocolClient msg)
-waitForProtocolClient clientConfig clientVar = do
-  ProtocolClientConfig {tcpTimeout} <- asks $ clientConfig . config
-  client_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar clientVar)
+waitForProtocolClient :: AgentMonad m => AgentClient -> ClientVar msg -> m (ProtocolClient msg)
+waitForProtocolClient c 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
@@ -335,7 +361,7 @@ waitForProtocolClient clientConfig clientVar = do
 
 newProtocolClient ::
   forall msg m.
-  AgentMonad m =>
+  (AgentMonad m, ProtocolTypeI (ProtoType msg)) =>
   AgentClient ->
   ProtoServer msg ->
   TMap (ProtoServer msg) (ClientVar msg) ->
@@ -351,9 +377,10 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
         Right client -> do
           logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
           atomically $ putTMVar clientVar r
+          atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client)
           successAction client
         Left e -> do
-          if e == BROKER NETWORK || e == BROKER TIMEOUT
+          if temporaryAgentError e
             then retryAction
             else atomically $ do
               putTMVar clientVar (Left e)
@@ -368,30 +395,40 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
 
+hostEvent :: forall msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent
+hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost client
+
+updateClientConfig :: AgentClient -> ProtocolClientConfig -> STM ProtocolClientConfig
+updateClientConfig AgentClient {useNetworkConfig} cfg = do
+  networkConfig <- readTVar useNetworkConfig
+  pure cfg {networkConfig}
+
 closeAgentClient :: MonadIO m => AgentClient -> m ()
 closeAgentClient c = liftIO $ do
   atomically $ writeTVar (active c) False
-  closeProtocolServerClients (clientTimeout smpCfg) $ smpClients c
-  closeProtocolServerClients (clientTimeout ntfCfg) $ ntfClients c
+  closeProtocolServerClients c smpClients
+  closeProtocolServerClients c ntfClients
   cancelActions $ reconnections c
   cancelActions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
-  clear subscrSrvrs
-  clear pendingSubscrSrvrs
+  atomically . TM2.clear $ activeSubs c
+  atomically . TM2.clear $ pendingSubs c
   clear subscrConns
   clear connMsgsQueued
   clear smpQueueMsgQueues
   clear getMsgLocks
   where
-    clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
-    clear :: (AgentClient -> TMap k a) -> IO ()
-    clear sel = atomically $ writeTVar (sel c) M.empty
+    clear :: Monoid m => (AgentClient -> TVar m) -> IO ()
+    clear sel = atomically $ writeTVar (sel c) mempty
 
-closeProtocolServerClients :: Int -> TMap (ProtoServer msg) (ClientVar msg) -> IO ()
-closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO ()
+closeProtocolServerClients c clientsSel =
+  readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
   where
-    closeClient cVar =
-      tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
+    cs = clientsSel c
+    closeClient cVar = do
+      NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
+      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
         _ -> pure ()
 
@@ -435,28 +472,32 @@ protocolClientError protocolError_ = \case
   PCEUnexpectedResponse _ -> BROKER UNEXPECTED
   PCEResponseTimeout -> BROKER TIMEOUT
   PCENetworkError -> BROKER NETWORK
+  PCEIncompatibleHost -> BROKER HOST
   PCETransportError e -> BROKER $ TRANSPORT e
   e@PCESignatureError {} -> INTERNAL $ show e
   e@PCEIOError {} -> INTERNAL $ show e
 
-newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
-newRcvQueue c srv =
+newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> VersionRange -> Bool -> m (RcvQueue, SMPQueueUri)
+newRcvQueue c srv vRange current =
   asks (cmdSignAlg . config) >>= \case
-    C.SignAlg a -> newRcvQueue_ a c srv
+    C.SignAlg a -> newRcvQueue_ a c srv vRange current
 
 newRcvQueue_ ::
   (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>
   C.SAlgorithm a ->
   AgentClient ->
   SMPServer ->
+  VersionRange ->
+  Bool ->
   m (RcvQueue, SMPQueueUri)
-newRcvQueue_ a c srv = do
+newRcvQueue_ a c srv vRange current = do
   (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
   (dhKey, privDhKey) <- liftIO C.generateKeyPair'
   (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   logServer "-->" c srv "" "NEW"
   QIK {rcvId, sndId, rcvPublicDhKey} <-
     withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
+  createdAt <- liftIO getCurrentTime
   logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
@@ -466,59 +507,98 @@ newRcvQueue_ a c srv = do
             rcvDhSecret = C.dh' rcvPublicDhKey privDhKey,
             e2ePrivKey,
             e2eDhSecret = Nothing,
-            sndId = Just sndId,
+            sndId,
+            sndPublicKey = Nothing,
             status = New,
-            clientNtfCreds = Nothing
+            rcvQueueAction = Nothing,
+            currRcvQueue = current,
+            dbNextRcvQueueId = Nothing,
+            clientNtfCreds = Nothing,
+            smpClientVersion = maxVersion vRange,
+            createdAt,
+            updatedAt = createdAt
           }
-  pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)
+  pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey)
 
-subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
-subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
+subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> Bool -> m ()
+subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId current = do
   whenM (atomically . TM.member (server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED
-  atomically $ addPendingSubscription c rq connId
-  withLogClient c server rcvId "SUB" $ \smp -> do
-    liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
-      Left e -> do
-        atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
-          removePendingSubscription c server connId
-        throwError e
-      Right _ -> do
-        addSubscription c rq connId
+  atomically $ do
+    when current $ modifyTVar (subscrConns c) $ S.insert connId
+    TM2.insert server (connId, current) rq $ pendingSubs c
+  withLogClient c server rcvId "SUB" $ \smp ->
+    liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq connId current)
+      >>= either throwError pure
 
-addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
-addSubscription c rq@RcvQueue {server} connId = atomically $ do
-  TM.insert connId server $ subscrConns c
-  addSubs_ (subscrSrvrs c) rq connId
-  removePendingSubscription c server connId
+processSubResult :: AgentClient -> RcvQueue -> ConnId -> Bool -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
+processSubResult c rq connId current r = do
+  case r of
+    Left e ->
+      atomically . unless (temporaryClientError e) $
+        TM2.delete (connId, current) (pendingSubs c)
+    _ -> addSubscription c rq connId current
+  pure r
+
+temporaryClientError :: ProtocolClientError -> Bool
+temporaryClientError = \case
+  PCENetworkError -> True
+  PCEResponseTimeout -> True
+  _ -> False
+
+temporaryAgentError :: AgentErrorType -> Bool
+temporaryAgentError = \case
+  BROKER NETWORK -> True
+  BROKER TIMEOUT -> True
+  _ -> False
+
+-- | subscribe multiple queues - all passed queues should be on the same server
+subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> Map (ConnId, Bool) RcvQueue -> m (Maybe SMPClient, Map (ConnId, Bool) (Either AgentErrorType ()))
+subscribeQueues c srv qs = do
+  (errs, qs_) <- partitionEithers <$> mapM checkQueue (M.assocs qs)
+  forM_ qs_ $ \(sub@(connId, current), rq@RcvQueue {server}) -> atomically $ do
+    when current . modifyTVar (subscrConns c) $ S.insert connId
+    TM2.insert server sub rq $ pendingSubs c
+  case L.nonEmpty qs_ of
+    Just qs' -> do
+      smp_ <- tryError (getSMPServerClient c srv)
+      (eitherToMaybe smp_,) . M.fromList . (errs <>) <$> case smp_ of
+        Left e -> pure $ map (second . const $ Left e) qs_
+        Right smp -> do
+          logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB"
+          let qs2 = L.map (queueCreds . snd) qs'
+          rs' :: [(((ConnId, Bool), RcvQueue), Either ProtocolClientError ())] <-
+            liftIO $ zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
+          forM_ rs' $ \(((connId, current), rq), r) -> liftIO $ processSubResult c rq connId current r
+          pure $ map (bimap fst (first $ protocolClientError SMP)) rs'
+    _ -> pure $ (Nothing, M.fromList errs)
+  where
+    checkQueue rq@(connId, RcvQueue {rcvId, server}) = do
+      prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
+      pure $ if prohibited || srv /= server then Left (connId, Left $ CMD PROHIBITED) else Right rq
+    queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
+
+addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> Bool -> m ()
+addSubscription c rq@RcvQueue {server} connId current = atomically $ do
+  modifyTVar (subscrConns c) $ S.insert connId
+  let sub = (connId, current)
+  TM2.insert server sub rq $ activeSubs c
+  TM2.delete sub $ pendingSubs c
 
 hasActiveSubscription :: AgentClient -> ConnId -> STM Bool
-hasActiveSubscription c connId = TM.member connId (subscrConns c)
-
-addPendingSubscription :: AgentClient -> RcvQueue -> ConnId -> STM ()
-addPendingSubscription = addSubs_ . pendingSubscrSrvrs
-
-addSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> RcvQueue -> ConnId -> STM ()
-addSubs_ ss rq@RcvQueue {server} connId =
-  TM.lookup server ss >>= \case
-    Just m -> TM.insert connId rq m
-    _ -> TM.singleton connId rq >>= \m -> TM.insert server m ss
+hasActiveSubscription c connId = TM2.member (connId, True) $ activeSubs c
 
 removeSubscription :: AgentClient -> ConnId -> STM ()
-removeSubscription c@AgentClient {subscrConns} connId = do
-  server_ <- TM.lookupDelete connId subscrConns
-  mapM_ (\server -> removeSubs_ (subscrSrvrs c) server connId) server_
-
-removePendingSubscription :: AgentClient -> SMPServer -> ConnId -> STM ()
-removePendingSubscription = removeSubs_ . pendingSubscrSrvrs
-
-removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> STM ()
-removeSubs_ ss server connId =
-  TM.lookup server ss >>= mapM_ (TM.delete connId)
+removeSubscription c connId = do
+  modifyTVar (subscrConns c) $ S.delete connId
+  delete (connId, True)
+  delete (connId, False)
+  where
+    delete sub = do
+      TM2.delete sub $ activeSubs c
+      TM2.delete sub $ pendingSubs c
 
 getSubscriptions :: AgentClient -> STM (Set ConnId)
-getSubscriptions AgentClient {subscrConns} = do
-  m <- readTVar subscrConns
-  pure $ M.keysSet m
+getSubscriptions = readTVar . subscrConns
 
 logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
@@ -526,7 +606,7 @@ logServer dir AgentClient {clientId} srv qId cmdStr =
 
 showServer :: ProtocolServer s -> ByteString
 showServer ProtocolServer {host, port} =
-  B.pack $ host <> if null port then "" else ':' : port
+  strEncode host <> B.pack (if null port then "" else ':' : port)
 
 logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
@@ -540,7 +620,7 @@ sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey,
 sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
 sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) (Compatible agentVersion) connReq connInfo =
+sendInvitation c (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo =
   withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
     msg <- mkInvitation
     liftClient SMP $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
@@ -549,7 +629,7 @@ sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) (C
     -- this is only encrypted with per-queue E2E, not with double ratchet
     mkInvitation = do
       let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
-      agentCbEncryptOnce dhPublicKey . smpEncode $
+      agentCbEncryptOnce v dhPublicKey . smpEncode $
         SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
 
 getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
@@ -599,7 +679,7 @@ releaseGetLock :: AgentClient -> RcvQueue -> STM ()
 releaseGetLock c RcvQueue {server, rcvId} =
   TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
 
-suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
+suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m Word16
 suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
   withLogClient c server rcvId "OFF" $ \smp ->
     suspendSMPQueue smp rcvPrivateKey rcvId
@@ -653,27 +733,25 @@ agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
 
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
-agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
+agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
   cmNonce <- liftIO C.randomCbNonce
   let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey
   cmEncBody <-
     liftEither . first cryptoError $
       C.cbEncrypt e2eDhSecret cmNonce msg paddedLen
-  -- TODO per-queue client version
-  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) e2ePubKey
+  let cmHeader = SMP.PubHeader smpClientVersion e2ePubKey
   pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
 
 -- add encoding as AgentInvitation'?
-agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString
-agentCbEncryptOnce dhRcvPubKey msg = do
+agentCbEncryptOnce :: AgentMonad m => Version -> C.PublicKeyX25519 -> ByteString -> m ByteString
+agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
   (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
   let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
   cmNonce <- liftIO C.randomCbNonce
   cmEncBody <-
     liftEither . first cryptoError $
       C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength
-  -- TODO per-queue client version
-  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) (Just dhSndPubKey)
+  let cmHeader = SMP.PubHeader clientVersion (Just dhSndPubKey)
   pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
 
 -- | NaCl crypto-box decrypt - both for messages received from the server
@@ -762,15 +840,16 @@ withStore c action = do
   where
     handleInternal :: E.SomeException -> IO (Either StoreError a)
     handleInternal = pure . Left . SEInternal . bshow
-    storeError :: StoreError -> AgentErrorType
-    storeError = \case
-      SEConnNotFound -> CONN NOT_FOUND
-      SEConnDuplicate -> CONN DUPLICATE
-      SEBadConnType CRcv -> CONN SIMPLEX
-      SEBadConnType CSnd -> CONN SIMPLEX
-      SEInvitationNotFound -> CMD PROHIBITED
-      -- this error is never reported as store error,
-      -- it is used to wrap agent operations when "transaction-like" store access is needed
-      -- NOTE: network IO should NOT be used inside AgentStoreMonad
-      SEAgentError e -> e
-      e -> INTERNAL $ show e
+
+storeError :: StoreError -> AgentErrorType
+storeError = \case
+  SEConnNotFound -> CONN NOT_FOUND
+  SEConnDuplicate -> CONN DUPLICATE
+  SEBadConnType CRcv -> CONN SIMPLEX
+  SEBadConnType CSnd -> CONN SIMPLEX
+  SEInvitationNotFound -> CMD PROHIBITED
+  -- this error is never reported as store error,
+  -- it is used to wrap agent operations when "transaction-like" store access is needed
+  -- NOTE: network IO should NOT be used inside AgentStoreMonad
+  SEAgentError e -> e
+  e -> INTERNAL $ show e

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

@@ -13,6 +13,7 @@ module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
     AgentConfig (..),
     InitialAgentServers (..),
+    NetworkConfig (..),
     defaultAgentConfig,
     defaultReconnectInterval,
     Env (..),
@@ -39,10 +40,11 @@ import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer)
+import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
+import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
@@ -53,7 +55,8 @@ type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorTy
 
 data InitialAgentServers = InitialAgentServers
   { smp :: NonEmpty SMPServer,
-    ntf :: [NtfServer]
+    ntf :: [NtfServer],
+    netCfg :: NetworkConfig
   }
 
 data AgentConfig = AgentConfig
@@ -66,8 +69,9 @@ data AgentConfig = AgentConfig
     smpCfg :: ProtocolClientConfig,
     ntfCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
+    messageRetryInterval :: RetryInterval,
+    messageTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
-    resubscriptionConcurrency :: Int,
     ntfCron :: Word16,
     ntfWorkerDelay :: Int,
     ntfSMPWorkerDelay :: Int,
@@ -76,19 +80,25 @@ data AgentConfig = AgentConfig
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
-    smpAgentVersion :: Version,
-    smpAgentVRange :: VersionRange
+    smpAgentVRange :: VersionRange,
+    smpClientVRange :: VersionRange
   }
 
 defaultReconnectInterval :: RetryInterval
 defaultReconnectInterval =
   RetryInterval
-    { initialInterval = second,
-      increaseAfter = 10 * second,
-      maxInterval = 10 * second
+    { initialInterval = 2_000000,
+      increaseAfter = 10_000000,
+      maxInterval = 180_000000
+    }
+
+defaultMessageRetryInterval :: RetryInterval
+defaultMessageRetryInterval =
+  RetryInterval
+    { initialInterval = 1_000000,
+      increaseAfter = 10_000000,
+      maxInterval = 60_000000
     }
-  where
-    second = 1_000_000
 
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
@@ -99,11 +109,12 @@ defaultAgentConfig =
       tbqSize = 64,
       dbFile = "smp-agent.db",
       yesToMigrations = False,
-      smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
+      smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
       ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
       reconnectInterval = defaultReconnectInterval,
+      messageRetryInterval = defaultMessageRetryInterval,
+      messageTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
-      resubscriptionConcurrency = 16,
       ntfCron = 20, -- minutes
       ntfWorkerDelay = 100000, -- microseconds
       ntfSMPWorkerDelay = 500000, -- microseconds
@@ -114,8 +125,8 @@ defaultAgentConfig =
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
       privateKeyFile = "/etc/opt/simplex-agent/agent.key",
       certificateFile = "/etc/opt/simplex-agent/agent.crt",
-      smpAgentVersion = currentSMPAgentVersion,
-      smpAgentVRange = supportedSMPAgentVRange
+      smpAgentVRange = supportedSMPAgentVRange,
+      smpClientVRange = supportedSMPClientVRange
     }
 
 data Env = Env

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
     nsUpdateToken,
     nsRemoveNtfToken,
     sendNtfSubCommand,
+    instantNotifications,
     closeNtfSupervisor,
     getNtfServer,
   )
@@ -327,13 +328,14 @@ nsRemoveNtfToken :: NtfSupervisor -> STM ()
 nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
 
 sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
-sendNtfSubCommand ns cmd =
-  readTVar (ntfTkn ns)
-    >>= mapM_
-      ( \NtfToken {ntfTknStatus, ntfMode} ->
-          when (ntfTknStatus == NTActive && ntfMode == NMInstant) $
-            writeTBQueue (ntfSubQ ns) cmd
-      )
+sendNtfSubCommand ns cmd = do
+  tkn <- readTVar (ntfTkn ns)
+  when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
+
+instantNotifications :: Maybe NtfToken -> Bool
+instantNotifications = \case
+  Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
+  _ -> False
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()
 closeNtfSupervisor ns = do

src/Simplex/Messaging/Agent/Protocol.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
@@ -32,7 +33,6 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
 module Simplex.Messaging.Agent.Protocol
   ( -- * Protocol parameters
-    currentSMPAgentVersion,
     supportedSMPAgentVRange,
     e2eEncConnInfoLength,
     e2eEncUserMsgLength,
@@ -40,10 +40,13 @@ module Simplex.Messaging.Agent.Protocol
     -- * SMP agent protocol types
     ConnInfo,
     ACommand (..),
+    ACmd (..),
     AParty (..),
     SAParty (..),
     MsgHash,
     MsgMeta (..),
+    SwitchPhase (..),
+    ConnectionStats (..),
     SMPConfirmation (..),
     AgentMsgEnvelope (..),
     AgentMessage (..),
@@ -55,6 +58,7 @@ module Simplex.Messaging.Agent.Protocol
     SrvLoc (..),
     SMPQueueUri (..),
     SMPQueueInfo (..),
+    SMPQueueAddress (..),
     ConnectionMode (..),
     SConnectionMode (..),
     AConnectionMode (..),
@@ -89,11 +93,15 @@ module Simplex.Messaging.Agent.Protocol
     serializeCommand,
     connMode,
     connMode',
+    networkCommandP,
+    dbCommandP,
     commandP,
     connModeT,
     serializeQueueStatus,
     queueStatusT,
     agentMessageType,
+    extraSMPServerHosts,
+    updateSMPServerHosts,
 
     -- * TCP transport functions
     tPut,
@@ -116,7 +124,10 @@ import Data.Composition ((.:), (.:.))
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Kind (Type)
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
@@ -135,18 +146,24 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
-  ( ErrorType,
+  ( AProtocolType,
+    ErrorType,
     MsgBody,
     MsgFlags,
     MsgId,
     NMsgMeta,
+    ProtocolServer (..),
     SMPServer,
     SndPublicVerifyKey,
     SrvLoc (..),
+    legacyEncodeServer,
+    legacyServerP,
+    legacyStrEncodeServer,
     pattern SMPServer,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
+import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
@@ -205,20 +222,23 @@ type ConnInfo = ByteString
 
 -- | Parameterized type for SMP agent protocol commands and responses from all participants.
 data ACommand (p :: AParty) where
-  NEW :: AConnectionMode -> ACommand Client -- response INV
+  NEW :: Bool -> AConnectionMode -> ACommand Client -- response INV
   INV :: AConnectionRequestUri -> ACommand Agent
-  JOIN :: AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
-  CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
+  JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
+  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
   LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
-  REQ :: InvitationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
+  REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
   ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
   RJCT :: InvitationId -> ACommand Client
   INFO :: ConnInfo -> ACommand Agent
   CON :: ACommand Agent -- notification that connection is established
   SUB :: ACommand Client
   END :: ACommand Agent
+  CONNECT :: AProtocolType -> TransportHost -> ACommand Agent
+  DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent
   DOWN :: SMPServer -> [ConnId] -> ACommand Agent
   UP :: SMPServer -> [ConnId] -> ACommand Agent
+  SWITCH :: SwitchPhase -> ConnectionStats -> ACommand Agent
   SEND :: MsgFlags -> MsgBody -> ACommand Client
   MID :: AgentMsgId -> ACommand Agent
   SENT :: AgentMsgId -> ACommand Agent
@@ -227,6 +247,8 @@ data ACommand (p :: AParty) where
   ACK :: AgentMsgId -> ACommand Client
   OFF :: ACommand Client
   DEL :: ACommand Client
+  CHK :: ACommand Client
+  STAT :: ConnectionStats -> ACommand Agent
   OK :: ACommand Agent
   ERR :: AgentErrorType -> ACommand Agent
   SUSPENDED :: ACommand Agent
@@ -235,6 +257,44 @@ deriving instance Eq (ACommand p)
 
 deriving instance Show (ACommand p)
 
+data SwitchPhase = SPStarted | SPCompleted
+  deriving (Eq, Show)
+
+instance StrEncoding SwitchPhase where
+  strEncode = \case
+    SPStarted -> "started"
+    SPCompleted -> "completed"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "started" -> pure SPStarted
+      "completed" -> pure SPCompleted
+      _ -> fail "bad SwitchPhase"
+
+data ConnectionStats = ConnectionStats
+  { rcvServers :: [SMPServer],
+    sndServers :: [SMPServer],
+    nextRcvServers :: [SMPServer],
+    nextSndServers :: [SMPServer]
+  }
+  deriving (Eq, Show, Generic)
+
+instance StrEncoding ConnectionStats where
+  strEncode s =
+    B.unwords
+      [ "rcv=" <> strEncodeList (rcvServers s),
+        "snd=" <> strEncodeList (sndServers s),
+        "next_rcv=" <> strEncodeList (nextRcvServers s),
+        "next_snd=" <> strEncodeList (nextSndServers s)
+      ]
+  strP = do
+    rcvServers <- "rcv=" *> strListP
+    sndServers <- " snd=" *> strListP
+    nextRcvServers <- " next_rcv=" *> strListP
+    nextSndServers <- " next_snd=" *> strListP
+    pure ConnectionStats {rcvServers, sndServers, nextRcvServers, nextSndServers}
+
+instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
+
 data NotificationsMode = NMPeriodic | NMInstant
   deriving (Eq, Show)
 
@@ -325,7 +385,9 @@ data SMPConfirmation = SMPConfirmation
     -- | sender's information to be associated with the connection, e.g. sender's profile information
     connInfo :: ConnInfo,
     -- | optional reply queues included in confirmation (added in agent protocol v2)
-    smpReplyQueues :: [SMPQueueInfo]
+    smpReplyQueues :: [SMPQueueInfo],
+    -- | SMP client version
+    smpClientVersion :: Version
   }
   deriving (Show)
 
@@ -391,7 +453,18 @@ instance Encoding AgentMessage where
       'M' -> AgentMessage <$> smpP <*> smpP
       _ -> fail "bad AgentMessage"
 
-data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
+data AgentMessageType
+  = AM_CONN_INFO
+  | AM_CONN_INFO_REPLY
+  | AM_HELLO_
+  | AM_REPLY_
+  | AM_A_MSG_
+  | AM_QNEW_
+  | AM_QKEYS_
+  | AM_QREADY_
+  | AM_QTEST_
+  | AM_QSWITCH_
+  | AM_QHELLO_
   deriving (Eq, Show)
 
 instance Encoding AgentMessageType where
@@ -401,6 +474,12 @@ instance Encoding AgentMessageType where
     AM_HELLO_ -> "H"
     AM_REPLY_ -> "R"
     AM_A_MSG_ -> "M"
+    AM_QNEW_ -> "QN"
+    AM_QKEYS_ -> "QK"
+    AM_QREADY_ -> "QR"
+    AM_QTEST_ -> "QT"
+    AM_QSWITCH_ -> "QS"
+    AM_QHELLO_ -> "QH"
   smpP =
     A.anyChar >>= \case
       'C' -> pure AM_CONN_INFO
@@ -408,6 +487,15 @@ instance Encoding AgentMessageType where
       'H' -> pure AM_HELLO_
       'R' -> pure AM_REPLY_
       'M' -> pure AM_A_MSG_
+      'Q' ->
+        A.anyChar >>= \case
+          'N' -> pure AM_QNEW_
+          'K' -> pure AM_QKEYS_
+          'R' -> pure AM_QREADY_
+          'T' -> pure AM_QTEST_
+          'S' -> pure AM_QSWITCH_
+          'H' -> pure AM_QHELLO_
+          _ -> fail "bad AgentMessageType"
       _ -> fail "bad AgentMessageType"
 
 agentMessageType :: AgentMessage -> AgentMessageType
@@ -423,6 +511,12 @@ agentMessageType = \case
     -- REPLY is only used in v1
     REPLY _ -> AM_REPLY_
     A_MSG _ -> AM_A_MSG_
+    QNEW {} -> AM_QNEW_
+    QKEYS {} -> AM_QKEYS_
+    QREADY {} -> AM_QREADY_
+    QTEST -> AM_QTEST_
+    QSWITCH {} -> AM_QSWITCH_
+    QHELLO -> AM_QHELLO_
 
 data APrivHeader = APrivHeader
   { -- | sequential ID assigned by the sending agent
@@ -437,7 +531,16 @@ instance Encoding APrivHeader where
     smpEncode (sndMsgId, prevMsgHash)
   smpP = APrivHeader <$> smpP <*> smpP
 
-data AMsgType = HELLO_ | REPLY_ | A_MSG_
+data AMsgType
+  = HELLO_
+  | REPLY_
+  | A_MSG_
+  | QNEW_
+  | QKEYS_
+  | QREADY_
+  | QTEST_
+  | QSWITCH_
+  | QHELLO_
   deriving (Eq)
 
 instance Encoding AMsgType where
@@ -445,11 +548,26 @@ instance Encoding AMsgType where
     HELLO_ -> "H"
     REPLY_ -> "R"
     A_MSG_ -> "M"
+    QNEW_ -> "QN"
+    QKEYS_ -> "QK"
+    QREADY_ -> "QR"
+    QTEST_ -> "QT"
+    QSWITCH_ -> "QS"
+    QHELLO_ -> "QH"
   smpP =
-    smpP >>= \case
+    A.anyChar >>= \case
       'H' -> pure HELLO_
       'R' -> pure REPLY_
       'M' -> pure A_MSG_
+      'Q' ->
+        A.anyChar >>= \case
+          'N' -> pure QNEW_
+          'K' -> pure QKEYS_
+          'R' -> pure QREADY_
+          'T' -> pure QTEST_
+          'S' -> pure QSWITCH_
+          'H' -> pure QHELLO_
+          _ -> fail "bad AMsgType"
       _ -> fail "bad AMsgType"
 
 -- | Messages sent between SMP agents once SMP queue is secured.
@@ -462,6 +580,18 @@ data AMessage
     REPLY (L.NonEmpty SMPQueueInfo)
   | -- | agent envelope for the client message
     A_MSG MsgBody
+  | -- | instruct sender to switch the queue to another
+    QNEW {currentAddress :: (SMPServer, SMP.SenderId), nextQueueUri :: SMPQueueUri}
+  | -- | send server key and queue e2e DH key to the recipient
+    QKEYS {nextSenderKey :: SndPublicVerifyKey, nextQueueInfo :: SMPQueueInfo}
+  | -- | inform the sender that the queue is ready to use - sender sends QHELLO to it
+    QREADY {nextAddress :: (SMPServer, SMP.SenderId)}
+  | -- | the message sent by the sender to the new queue to test delivery
+    QTEST
+  | -- | instruct the sender to start sending messages to the new queue - after recipient receives HELLO
+    QSWITCH {nextAddress :: (SMPServer, SMP.SenderId)}
+  | -- | confirm that the delivery is switched, all new messages will be sent to the new queue
+    QHELLO
   deriving (Show)
 
 instance Encoding AMessage where
@@ -469,12 +599,27 @@ instance Encoding AMessage where
     HELLO -> smpEncode HELLO_
     REPLY smpQueues -> smpEncode (REPLY_, smpQueues)
     A_MSG body -> smpEncode (A_MSG_, Tail body)
+    QNEW currAddr nextQUri -> smpEncode (QNEW_, currAddr, strEncode nextQUri)
+    QKEYS sKey nextQInfo -> smpEncode (QKEYS_, sKey, nextQInfo)
+    QREADY addr -> smpEncode (QREADY_, addr)
+    QTEST -> smpEncode QTEST_
+    QSWITCH addr -> smpEncode (QSWITCH_, addr)
+    QHELLO -> smpEncode QHELLO_
   smpP =
     smpP
       >>= \case
         HELLO_ -> pure HELLO
         REPLY_ -> REPLY <$> smpP
         A_MSG_ -> A_MSG . unTail <$> smpP
+        QNEW_ -> do
+          currentAddress <- smpP
+          nextQueueUri <- strDecode <$?> smpP
+          pure QNEW {currentAddress, nextQueueUri}
+        QKEYS_ -> QKEYS <$> smpP <*> smpP
+        QREADY_ -> QREADY <$> smpP
+        QTEST_ -> pure QTEST
+        QSWITCH_ -> QSWITCH <$> smpP
+        QHELLO_ -> pure QHELLO
 
 instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
   strEncode = \case
@@ -553,20 +698,36 @@ type ConfirmationId = ByteString
 
 type InvitationId = ByteString
 
-data SMPQueueInfo = SMPQueueInfo
-  { clientVersion :: Version,
-    smpServer :: SMPServer,
-    senderId :: SMP.SenderId,
-    dhPublicKey :: C.PublicKeyX25519
-  }
+extraSMPServerHosts :: Map TransportHost TransportHost
+extraSMPServerHosts =
+  M.fromList
+    [ ("smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
+      ("smp5.simplex.im", "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"),
+      ("smp6.simplex.im", "bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"),
+      ("smp8.simplex.im", "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion"),
+      ("smp9.simplex.im", "jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion"),
+      ("smp10.simplex.im", "rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion")
+    ]
+
+updateSMPServerHosts :: SMPServer -> SMPServer
+updateSMPServerHosts srv@ProtocolServer {host} = case host of
+  h :| [] -> case M.lookup h extraSMPServerHosts of
+    Just h' -> srv {host = [h, h']}
+    _ -> srv
+  _ -> srv
+
+data SMPQueueInfo = SMPQueueInfo {clientVersion :: Version, queueAddress :: SMPQueueAddress}
   deriving (Eq, Show)
 
 instance Encoding SMPQueueInfo where
-  smpEncode SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey} =
-    smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
+  smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey})
+    | clientVersion > 1 = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
+    | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
   smpP = do
-    (clientVersion, smpServer, senderId, dhPublicKey) <- smpP
-    pure SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey}
+    clientVersion <- smpP
+    smpServer <- if clientVersion > 1 then smpP else updateSMPServerHosts <$> legacyServerP
+    (senderId, dhPublicKey) <- smpP
+    pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}
 
 -- This instance seems contrived and there was a temptation to split a common part of both types.
 -- But this is created to allow backward and forward compatibility where SMPQueueUri
@@ -575,43 +736,51 @@ instance Encoding SMPQueueInfo where
 instance VersionI SMPQueueInfo where
   type VersionRangeT SMPQueueInfo = SMPQueueUri
   version = clientVersion
-  toVersionRangeT SMPQueueInfo {smpServer, senderId, dhPublicKey} vr =
-    SMPQueueUri {clientVRange = vr, smpServer, senderId, dhPublicKey}
+  toVersionRangeT (SMPQueueInfo _v addr) vr = SMPQueueUri vr addr
 
 instance VersionRangeI SMPQueueUri where
   type VersionT SMPQueueUri = SMPQueueInfo
   versionRange = clientVRange
-  toVersionT SMPQueueUri {smpServer, senderId, dhPublicKey} v =
-    SMPQueueInfo {clientVersion = v, smpServer, senderId, dhPublicKey}
+  toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr
 
 -- | SMP queue information sent out-of-band.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
-data SMPQueueUri = SMPQueueUri
+data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRange, queueAddress :: SMPQueueAddress}
+  deriving (Eq, Show)
+
+data SMPQueueAddress = SMPQueueAddress
   { smpServer :: SMPServer,
     senderId :: SMP.SenderId,
-    clientVRange :: VersionRange,
     dhPublicKey :: C.PublicKeyX25519
   }
   deriving (Eq, Show)
 
 instance StrEncoding SMPQueueUri where
-  -- v1 uses short SMP queue URI format
-  strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =
-    strEncode srv <> "/" <> strEncode qId <> "#" <> strEncode k
-  strP = do
-    smpServer <- strP <* A.char '/'
-    senderId <- strP <* optional (A.char '/') <* A.char '#'
-    (vr, dhPublicKey) <- unversioned <|> versioned
-    pure SMPQueueUri {smpServer, senderId, clientVRange = vr, dhPublicKey}
+  strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey})
+    | minVersion vr > 1 = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
+    | otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
     where
-      unversioned = (SMP.smpClientVRange,) <$> strP <* A.endOfInput
+      query = strEncode . QSP QEscape
+      queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)]
+      srvParam = [("srv", strEncode $ TransportHosts_ hs) | length hs > 0]
+      hs = L.tail $ host srv
+  strP = do
+    srv@ProtocolServer {host = h :| host} <- strP <* A.char '/'
+    senderId <- strP <* optional (A.char '/') <* A.char '#'
+    (vr, hs, dhPublicKey) <- unversioned <|> versioned
+    let srv' = srv {host = h :| host <> hs}
+        smpServer = if maxVersion vr == 1 then updateSMPServerHosts srv' else srv'
+    pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey}
+    where
+      unversioned = (versionToRange 1,[],) <$> strP <* A.endOfInput
       versioned = do
         dhKey_ <- optional strP
         query <- optional (A.char '/') *> A.char '?' *> strP
         vr <- queryParam "v" query
         dhKey <- maybe (queryParam "dh" query) pure dhKey_
-        pure (vr, dhKey)
+        hs_ <- queryParam_ "srv" query
+        pure (vr, maybe [] thList_ hs_, dhKey)
 
 data ConnectionRequestUri (m :: ConnectionMode) where
   CRInvitationUri :: ConnReqUriData -> E2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
@@ -747,7 +916,7 @@ data AgentErrorType
     AGENT {agentErr :: SMPAgentError}
   | -- | agent implementation or dependency errors
     INTERNAL {internalErr :: String}
-  deriving (Eq, Generic, Read, Show, Exception)
+  deriving (Eq, Generic, Show, Exception)
 
 instance ToJSON AgentErrorType where
   toJSON = J.genericToJSON $ sumTypeJSON id
@@ -797,6 +966,8 @@ data BrokerErrorType
     UNEXPECTED
   | -- | network error
     NETWORK
+  | -- | no compatible server host (e.g. onion when public is required, or vice versa)
+    HOST
   | -- | handshake or other transport error
     TRANSPORT {transportErr :: TransportError}
   | -- | command response timeout
@@ -858,9 +1029,17 @@ instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
 
 instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
 
+-- | SMP agent command and response parser for commands passed via network (only parses binary length)
+networkCommandP :: Parser ACmd
+networkCommandP = commandP A.takeByteString
+
+-- | SMP agent command and response parser for commands stored in db (fully parses binary bodies)
+dbCommandP :: Parser ACmd
+dbCommandP = commandP $ A.take =<< (A.decimal <* "\n")
+
 -- | SMP agent command and response parser
-commandP :: Parser ACmd
-commandP =
+commandP :: Parser ByteString -> Parser ACmd
+commandP parseByteString =
   "NEW " *> newCmd
     <|> "INV " *> invResp
     <|> "JOIN " *> joinCmd
@@ -872,8 +1051,11 @@ commandP =
     <|> "INFO " *> infoCmd
     <|> "SUB" $> ACmd SClient SUB
     <|> "END" $> ACmd SAgent END
-    <|> "DOWN " *> downsResp
-    <|> "UP " *> upsResp
+    <|> "CONNECT " *> connectResp
+    <|> "DISCONNECT " *> disconnectResp
+    <|> "DOWN " *> downResp
+    <|> "UP " *> upResp
+    <|> "SWITCH " *> switchResp
     <|> "SEND " *> sendCmd
     <|> "MID " *> msgIdResp
     <|> "SENT " *> sentResp
@@ -882,27 +1064,33 @@ commandP =
     <|> "ACK " *> ackCmd
     <|> "OFF" $> ACmd SClient OFF
     <|> "DEL" $> ACmd SClient DEL
+    <|> "CHK" $> ACmd SClient CHK
+    <|> "STAT " *> statResp
     <|> "ERR " *> agentError
     <|> "CON" $> ACmd SAgent CON
     <|> "OK" $> ACmd SAgent OK
   where
-    newCmd = ACmd SClient . NEW <$> strP
+    newCmd = ACmd SClient .: NEW <$> strP_ <*> strP
     invResp = ACmd SAgent . INV <$> strP
-    joinCmd = ACmd SClient .: JOIN <$> strP_ <*> A.takeByteString
-    confMsg = ACmd SAgent .: CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    reqMsg = ACmd SAgent .: REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
+    joinCmd = ACmd SClient .:. JOIN <$> strP_ <*> strP_ <*> parseByteString
+    confMsg = ACmd SAgent .:. CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> parseByteString
+    letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> parseByteString
+    reqMsg = ACmd SAgent .:. REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> parseByteString
+    acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> parseByteString
     rjctCmd = ACmd SClient . RJCT <$> A.takeByteString
-    infoCmd = ACmd SAgent . INFO <$> A.takeByteString
-    downsResp = ACmd SAgent .: DOWN <$> strP_ <*> connections
-    upsResp = ACmd SAgent .: UP <$> strP_ <*> connections
-    sendCmd = ACmd SClient .: SEND <$> smpP <* A.space <*> A.takeByteString
+    infoCmd = ACmd SAgent . INFO <$> parseByteString
+    connectResp = ACmd SAgent .: CONNECT <$> strP_ <*> strP
+    disconnectResp = ACmd SAgent .: DISCONNECT <$> strP_ <*> strP
+    downResp = ACmd SAgent .: DOWN <$> strP_ <*> connections
+    upResp = ACmd SAgent .: UP <$> strP_ <*> connections
+    switchResp = ACmd SAgent .: SWITCH <$> strP_ <*> strP
+    sendCmd = ACmd SClient .: SEND <$> smpP <* A.space <*> parseByteString
     msgIdResp = ACmd SAgent . MID <$> A.decimal
     sentResp = ACmd SAgent . SENT <$> A.decimal
     msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
-    message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> A.takeByteString
+    message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> parseByteString
     ackCmd = ACmd SClient . ACK <$> A.decimal
+    statResp = ACmd SAgent . STAT <$> strP
     connections = strP `A.sepBy'` A.char ','
     msgMetaP = do
       integrity <- strP
@@ -914,24 +1102,27 @@ commandP =
     agentError = ACmd SAgent . ERR <$> strP
 
 parseCommand :: ByteString -> Either AgentErrorType ACmd
-parseCommand = parse commandP $ CMD SYNTAX
+parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
 
 -- | Serialize SMP agent command.
 serializeCommand :: ACommand p -> ByteString
 serializeCommand = \case
-  NEW cMode -> "NEW " <> strEncode cMode
+  NEW ntfs cMode -> B.unwords ["NEW", strEncode ntfs, strEncode cMode]
   INV cReq -> "INV " <> strEncode cReq
-  JOIN cReq cInfo -> B.unwords ["JOIN", strEncode cReq, serializeBinary cInfo]
-  CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]
+  JOIN ntfs cReq cInfo -> B.unwords ["JOIN", strEncode ntfs, strEncode cReq, serializeBinary cInfo]
+  CONF confId srvs cInfo -> B.unwords ["CONF", confId, strEncodeList srvs, serializeBinary cInfo]
   LET confId cInfo -> B.unwords ["LET", confId, serializeBinary cInfo]
-  REQ invId cInfo -> B.unwords ["REQ", invId, serializeBinary cInfo]
+  REQ invId srvs cInfo -> B.unwords ["REQ", invId, strEncode srvs, serializeBinary cInfo]
   ACPT invId cInfo -> B.unwords ["ACPT", invId, serializeBinary cInfo]
   RJCT invId -> "RJCT " <> invId
   INFO cInfo -> "INFO " <> serializeBinary cInfo
   SUB -> "SUB"
   END -> "END"
+  CONNECT p h -> B.unwords ["CONNECT", strEncode p, strEncode h]
+  DISCONNECT p h -> B.unwords ["DISCONNECT", strEncode p, strEncode h]
   DOWN srv conns -> B.unwords ["DOWN", strEncode srv, connections conns]
   UP srv conns -> B.unwords ["UP", strEncode srv, connections conns]
+  SWITCH phase srvs -> B.unwords ["SWITCH", strEncode phase, strEncode srvs]
   SEND msgFlags msgBody -> "SEND " <> smpEncode msgFlags <> " " <> serializeBinary msgBody
   MID mId -> "MID " <> bshow mId
   SENT mId -> "SENT " <> bshow mId
@@ -940,6 +1131,8 @@ serializeCommand = \case
   ACK mId -> "ACK " <> bshow mId
   OFF -> "OFF"
   DEL -> "DEL"
+  CHK -> "CHK"
+  STAT srvs -> "STAT " <> strEncode srvs
   CON -> "CON"
   ERR e -> "ERR " <> strEncode e
   OK -> "OK"
@@ -995,11 +1188,13 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     tConnId :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p)
     tConnId (_, connId, _) cmd = case cmd of
       -- NEW, JOIN and ACPT have optional connId
-      NEW _ -> Right cmd
+      NEW _ _ -> Right cmd
       JOIN {} -> Right cmd
       ACPT {} -> Right cmd
       -- ERROR response does not always have connId
       ERR _ -> Right cmd
+      CONNECT {} -> Right cmd
+      DISCONNECT {} -> Right cmd
       DOWN {} -> Right cmd
       UP {} -> Right cmd
       -- other responses must have connId
@@ -1011,10 +1206,10 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     cmdWithMsgBody = \case
       SEND msgFlags body -> SEND msgFlags <$$> getBody body
       MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
-      JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
-      CONF confId cInfo -> CONF confId <$$> getBody cInfo
+      JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo
+      CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
       LET confId cInfo -> LET confId <$$> getBody cInfo
-      REQ invId cInfo -> REQ invId <$$> getBody cInfo
+      REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
       ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
       INFO cInfo -> INFO <$$> getBody cInfo
       cmd -> pure $ Right cmd

src/Simplex/Messaging/Agent/QueryString.hs

@@ -28,3 +28,9 @@ queryParam name (QSP _ q) =
   case find ((== name) . fst) q of
     Just (_, p) -> either fail pure $ parseAll strP p
     _ -> fail $ "no qs param " <> B.unpack name
+
+queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
+queryParam_ name (QSP _ q) =
+  case find ((== name) . fst) q of
+    Just (_, p) -> either fail pure $ parseAll strP p
+    _ -> pure Nothing

src/Simplex/Messaging/Agent/Store.hs

@@ -3,7 +3,9 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
@@ -18,6 +20,7 @@ import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgFlags,
@@ -49,11 +52,25 @@ data RcvQueue = RcvQueue
     -- | public sender's DH key and agreed shared DH secret for simple per-queue e2e
     e2eDhSecret :: Maybe C.DhSecretX25519,
     -- | sender queue ID
-    sndId :: Maybe SMP.SenderId,
+    sndId :: SMP.SenderId,
+    -- | public key used by the server to verify sender's transmissions
+    -- it is Maybe as previously it was not saved - old queues may have NULL in it.
+    -- For all new queues it is never cleared.
+    sndPublicKey :: Maybe C.APublicVerifyKey,
     -- | queue status
     status :: QueueStatus,
+    -- | action to perform, to be done on connection subscription, if it fails and not reset
+    rcvQueueAction :: Maybe (RcvQueueAction, UTCTime),
+    -- | True for the current receive queue
+    currRcvQueue :: Bool,
+    -- | database ID of the new queue created for this queue to switch to (queue rotation)
+    dbNextRcvQueueId :: Maybe Int64,
     -- | credentials used in context of notifications
-    clientNtfCreds :: Maybe ClientNtfCreds
+    clientNtfCreds :: Maybe ClientNtfCreds,
+    -- | SMP client version
+    smpClientVersion :: Version,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
   }
   deriving (Eq, Show)
 
@@ -74,6 +91,8 @@ data SndQueue = SndQueue
     -- | sender queue ID
     sndId :: SMP.SenderId,
     -- | key pair used by the sender to sign transmissions
+    -- sndPublicKey is Maybe as previously it was not saved - old queues may have NULL in it.
+    -- For all new queues it is never cleared.
     sndPublicKey :: Maybe C.APublicVerifyKey,
     sndPrivateKey :: SndPrivateSignKey,
     -- | DH public key used to negotiate per-queue e2e encryption
@@ -81,14 +100,24 @@ data SndQueue = SndQueue
     -- | shared DH secret agreed for simple per-queue e2e encryption
     e2eDhSecret :: C.DhSecretX25519,
     -- | queue status
-    status :: QueueStatus
+    status :: QueueStatus,
+    -- | action to perform, to be done on connection subscription, if it fails and not reset
+    sndQueueAction :: Maybe (SndQueueAction, UTCTime),
+    -- | True for the current send queue
+    currSndQueue :: Bool,
+    -- | database ID of the new queue created for this queue to switch to (queue rotation)
+    dbNextSndQueueId :: Maybe Int64,
+    -- | SMP client version
+    smpClientVersion :: Version,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
   }
   deriving (Eq, Show)
 
 -- * Connection types
 
 -- | Type of a connection.
-data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
+data ConnType = CNew | CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 
 -- | Connection of a specific type.
 --
@@ -101,22 +130,33 @@ data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show)
 -- - DuplexConnection is a connection that has both receive and send queues set up,
 --   typically created by upgrading a receive or a send connection with a missing queue.
 data Connection (d :: ConnType) where
+  NewConnection :: ConnData -> Connection CNew
   RcvConnection :: ConnData -> RcvQueue -> Connection CRcv
   SndConnection :: ConnData -> SndQueue -> Connection CSnd
-  DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex
+  DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Maybe RcvQueue -> Maybe SndQueue -> Connection CDuplex
   ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
 deriving instance Eq (Connection d)
 
 deriving instance Show (Connection d)
 
+connData :: Connection d -> ConnData
+connData = \case
+  NewConnection cData -> cData
+  RcvConnection cData _ -> cData
+  SndConnection cData _ -> cData
+  DuplexConnection cData _ _ _ _ -> cData
+  ContactConnection cData _ -> cData
+
 data SConnType :: ConnType -> Type where
+  SCNew :: SConnType CNew
   SCRcv :: SConnType CRcv
   SCSnd :: SConnType CSnd
   SCDuplex :: SConnType CDuplex
   SCContact :: SConnType CContact
 
 connType :: SConnType c -> ConnType
+connType SCNew = CNew
 connType SCRcv = CRcv
 connType SCSnd = CSnd
 connType SCDuplex = CDuplex
@@ -147,10 +187,41 @@ deriving instance Show SomeConn
 data ConnData = ConnData
   { connId :: ConnId,
     connAgentVersion :: Version,
+    enableNtfs :: Bool,
     duplexHandshake :: Maybe Bool -- added in agent protocol v2
   }
   deriving (Eq, Show)
 
+data RcvQueueAction
+  = RQACreateNextQueue
+  | RQASecureNextQueue
+  | RQASuspendCurrQueue
+  | RQADeleteCurrQueue
+  deriving (Eq, Show)
+
+instance TextEncoding RcvQueueAction where
+  textEncode = \case
+    RQACreateNextQueue -> "create"
+    RQASecureNextQueue -> "secure"
+    RQASuspendCurrQueue -> "suspend"
+    RQADeleteCurrQueue -> "delete"
+  textDecode = \case
+    "create" -> Just RQACreateNextQueue
+    "secure" -> Just RQASecureNextQueue
+    "suspend" -> Just RQASuspendCurrQueue
+    "delete" -> Just RQADeleteCurrQueue
+    _ -> Nothing
+
+data SndQueueAction = SQASwitchQueue
+  deriving (Eq, Show)
+
+instance TextEncoding SndQueueAction where
+  textEncode = \case
+    SQASwitchQueue -> "switch"
+  textDecode = \case
+    "switch" -> Just SQASwitchQueue
+    _ -> Nothing
+
 -- * Confirmation types
 
 data NewConfirmation = NewConfirmation
@@ -222,7 +293,8 @@ data SndMsgData = SndMsgData
     msgFlags :: MsgFlags,
     msgBody :: MsgBody,
     internalHash :: MsgHash,
-    prevMsgHash :: MsgHash
+    prevMsgHash :: MsgHash,
+    currSndQueue :: Bool
   }
 
 data PendingMsgData = PendingMsgData
@@ -230,7 +302,8 @@ data PendingMsgData = PendingMsgData
     msgType :: AgentMessageType,
     msgFlags :: MsgFlags,
     msgBody :: MsgBody,
-    internalTs :: InternalTs
+    internalTs :: InternalTs,
+    currSndQueue :: Bool
   }
   deriving (Show)
 
@@ -267,6 +340,8 @@ newtype InternalId = InternalId {unId :: Int64} deriving (Eq, Show)
 
 type InternalTs = UTCTime
 
+type AsyncCmdId = Int64
+
 -- * Store errors
 
 -- | Agent store error.
@@ -288,6 +363,8 @@ data StoreError
     SEInvitationNotFound
   | -- | Message not found
     SEMsgNotFound
+  | -- | Command not found
+    SECmdNotFound
   | -- | Currently not used. The intention was to pass current expected queue status in methods,
     -- as we always know what it should be at any stage of the protocol,
     -- and in case it does not match use this error.

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

@@ -15,6 +15,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -24,9 +25,13 @@ module Simplex.Messaging.Agent.Store.SQLite
     connectSQLiteStore,
 
     -- * Queues and connections
+    createNewConn,
+    updateNewConnRcv,
+    updateNewConnSnd,
     createRcvConn,
     createSndConn,
     getConn,
+    getConnData,
     getRcvConn,
     deleteConn,
     upgradeRcvConnToDuplex,
@@ -36,6 +41,13 @@ module Simplex.Messaging.Agent.Store.SQLite
     setSndQueueStatus,
     getRcvQueue,
     setRcvQueueNtfCreds,
+    getNextRcvQueue,
+    getNextSndQueue,
+    dbCreateNextRcvQueue,
+    dbCreateNextSndQueue,
+    setRcvQueueAction,
+    switchCurrRcvQueue,
+    switchCurrSndQueue,
     -- Confirmations
     createConfirmation,
     acceptConfirmation,
@@ -46,6 +58,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     createInvitation,
     getInvitation,
     acceptInvitation,
+    unacceptInvitation,
     deleteInvitation,
     -- Messages
     updateRcvIds,
@@ -64,6 +77,11 @@ module Simplex.Messaging.Agent.Store.SQLite
     getRatchet,
     getSkippedMsgKeys,
     updateRatchet,
+    -- Async commands
+    createCommand,
+    getPendingCommands,
+    getPendingCommand,
+    deleteCommand,
     -- Notification device token persistence
     createNtfToken,
     getSavedNtfToken,
@@ -84,6 +102,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     getNextNtfSubSMPAction,
     getActiveNtfToken,
     getNtfRcvQueue,
+    setConnectionNtfs,
 
     -- * utilities
     withConnection,
@@ -102,8 +121,11 @@ import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import Data.Char (toLower)
+import Data.Function (on)
 import Data.Functor (($>))
-import Data.List (find, foldl')
+import Data.Int (Int64)
+import Data.List (find, foldl', groupBy)
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, listToMaybe)
 import Data.Text (Text)
@@ -127,8 +149,9 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
-import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, pattern NtfServer)
+import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, SndPublicVerifyKey, pattern NtfServer)
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>))
 import Simplex.Messaging.Version
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
@@ -253,33 +276,72 @@ createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of
   ConnData {connId = ""} -> createWithRandomId gVar create
   ConnData {connId} -> create connId $> Right connId
 
+createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId)
+createNewConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} cMode =
+  createConn_ gVar cData $ \connId -> do
+    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+
+updateNewConnRcv :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError ())
+updateNewConnRcv db connId rq@RcvQueue {server} =
+  getConn db connId $>>= \case
+    (SomeConn _ NewConnection {}) -> updateConn
+    (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+  where
+    updateConn :: IO (Either StoreError ())
+    updateConn = do
+      upsertServer_ db server
+      void $ insertRcvQueue_ db connId rq
+      pure $ Right ()
+
+updateNewConnSnd :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError ())
+updateNewConnSnd db connId sq@SndQueue {server} =
+  getConn db connId $>>= \case
+    (SomeConn _ NewConnection {}) -> updateConn
+    (SomeConn _ SndConnection {}) -> updateConn -- to allow retries
+    (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+  where
+    updateConn :: IO (Either StoreError ())
+    updateConn = do
+      upsertServer_ db server
+      void $ insertSndQueue_ db connId sq
+      pure $ Right ()
+
 createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> IO (Either StoreError ConnId)
-createRcvConn db gVar cData q@RcvQueue {server} cMode =
+createRcvConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode =
   createConn_ gVar cData $ \connId -> do
     upsertServer_ db server
-    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, cMode, connAgentVersion cData, duplexHandshake cData)
-    insertRcvQueue_ db connId q
+    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+    void $ insertRcvQueue_ db connId q
 
 createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SndQueue -> IO (Either StoreError ConnId)
-createSndConn db gVar cData q@SndQueue {server} =
+createSndConn db gVar cData@ConnData {connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} = do
   createConn_ gVar cData $ \connId -> do
     upsertServer_ db server
-    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion cData, duplexHandshake cData)
-    insertSndQueue_ db connId q
+    DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?, ?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
+    -- TODO add queue ID in insertSndQueue_
+    void $ insertSndQueue_ db connId q
 
-getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError SomeConn)
-getRcvConn db ProtocolServer {host, port} rcvId =
-  DB.queryNamed
-    db
-    [sql|
-      SELECT q.conn_id
-      FROM rcv_queues q
-      WHERE q.host = :host AND q.port = :port AND q.rcv_id = :rcv_id;
-    |]
-    [":host" := host, ":port" := port, ":rcv_id" := rcvId]
-    >>= \case
-      [Only connId] -> getConn db connId
-      _ -> pure $ Left SEConnNotFound
+getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn))
+getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
+  (rq, connId) <-
+    ExceptT . firstRow (\(qRow :. Only connId) -> (toRcvQueue qRow, connId)) SEConnNotFound $
+      DB.query
+        db
+        [sql|
+          SELECT q.host, q.port, s.key_hash,
+            q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_key, q.status,
+            q.rcv_queue_action, q.rcv_queue_action_ts, q.curr_rcv_queue, q.next_rcv_queue_id,
+            q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
+            q.smp_client_version, q.created_at, q.updated_at,
+            q.conn_id
+          FROM rcv_queues q
+          INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+          WHERE q.host = ? AND q.port = ? AND q.rcv_id = ?
+        |]
+        (host, port, rcvId)
+  conn <- ExceptT $ getConn db connId
+  pure (rq, conn)
 
 deleteConn :: DB.Connection -> ConnId -> IO ()
 deleteConn db connId =
@@ -293,19 +355,19 @@ upgradeRcvConnToDuplex db connId sq@SndQueue {server} =
   getConn db connId $>>= \case
     (SomeConn _ RcvConnection {}) -> do
       upsertServer_ db server
-      insertSndQueue_ db connId sq
+      -- TODO save with queue ID
+      void $ insertSndQueue_ db connId sq
       pure $ Right ()
     (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
 
 upgradeSndConnToDuplex :: DB.Connection -> ConnId -> RcvQueue -> IO (Either StoreError ())
 upgradeSndConnToDuplex db connId rq@RcvQueue {server} =
-  getConn db connId >>= \case
-    Right (SomeConn _ SndConnection {}) -> do
+  getConn db connId $>>= \case
+    SomeConn _ SndConnection {} -> do
       upsertServer_ db server
-      insertRcvQueue_ db connId rq
+      void $ insertRcvQueue_ db connId rq
       pure $ Right ()
-    Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
-    _ -> pure $ Left SEConnNotFound
+    SomeConn c _ -> pure . Left . SEBadConnType $ connType c
 
 setRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO ()
 setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} status =
@@ -319,18 +381,22 @@ setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} stat
     |]
     [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
 
-setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> IO ()
-setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret =
+setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.APublicVerifyKey -> C.DhSecretX25519 -> Version -> IO ()
+setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} sndPublicKey e2eDhSecret smpClientVersion =
   DB.executeNamed
     db
     [sql|
       UPDATE rcv_queues
       SET e2e_dh_secret = :e2e_dh_secret,
-          status = :status
+          snd_key = :snd_key,
+          status = :status,
+          smp_client_version = :smp_client_version
       WHERE host = :host AND port = :port AND rcv_id = :rcv_id
     |]
     [ ":status" := Confirmed,
       ":e2e_dh_secret" := e2eDhSecret,
+      ":snd_key" := sndPublicKey,
+      ":smp_client_version" := smpClientVersion,
       ":host" := host,
       ":port" := port,
       ":rcv_id" := rcvId
@@ -367,16 +433,111 @@ setRcvQueueNtfCreds db connId clientNtfCreds =
       Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
       Nothing -> (Nothing, Nothing, Nothing, Nothing)
 
+getNextRcvQueue :: DB.Connection -> RcvQueue -> IO (Maybe RcvQueue)
+getNextRcvQueue db RcvQueue {dbNextRcvQueueId} = case dbNextRcvQueueId of
+  Just rqId ->
+    maybeFirstRow toRcvQueue $
+      DB.query
+        db
+        [sql|
+          SELECT q.host, q.port, s.key_hash,
+            q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_key, q.status,
+            q.rcv_queue_action, q.rcv_queue_action_ts, q.curr_rcv_queue, q.next_rcv_queue_id,
+            q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
+            q.smp_client_version, q.created_at, q.updated_at
+          FROM rcv_queues q
+          INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+          WHERE q.rcv_queue_id = ? AND q.curr_rcv_queue = ?
+        |]
+        (rqId, False)
+  _ -> pure Nothing
+
+getNextSndQueue :: DB.Connection -> SndQueue -> IO (Maybe SndQueue)
+getNextSndQueue db SndQueue {dbNextSndQueueId} = case dbNextSndQueueId of
+  Just sqId ->
+    maybeFirstRow toSndQueue $
+      DB.query
+        db
+        [sql|
+          SELECT q.host, q.port, s.key_hash,
+            q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
+            q.snd_queue_action, q.snd_queue_action_ts, q.curr_snd_queue, q.next_snd_queue_id,
+            q.smp_client_version, q.created_at, q.updated_at
+          FROM snd_queues q
+          INNER JOIN servers s ON q.host = s.host AND q.port = s.port
+          WHERE q.snd_queue_id = ? AND q.curr_snd_queue = ?
+        |]
+        (sqId, False)
+  _ -> pure Nothing
+
+dbCreateNextRcvQueue :: DB.Connection -> ConnId -> RcvQueue -> RcvQueue -> IO ()
+dbCreateNextRcvQueue db connId RcvQueue {server = (SMPServer host port _), rcvId} rq' = do
+  rqId <- insertRcvQueue_ db connId rq'
+  DB.execute
+    db
+    [sql|
+      UPDATE rcv_queues
+      SET next_rcv_queue_id = ?
+      WHERE host = ? AND port = ? AND rcv_id = ? AND curr_rcv_queue = ?
+    |]
+    (rqId, host, port, rcvId, True)
+
+dbCreateNextSndQueue :: DB.Connection -> ConnId -> SndQueue -> SndQueue -> IO ()
+dbCreateNextSndQueue db connId SndQueue {server = (SMPServer host port _), sndId} sq' = do
+  sqId <- insertSndQueue_ db connId sq'
+  DB.execute
+    db
+    [sql|
+      UPDATE snd_queues
+      SET next_snd_queue_id = ?
+      WHERE host = ? AND port = ? AND snd_id = ? AND curr_snd_queue = ?
+    |]
+    (sqId, host, port, sndId, True)
+
+setRcvQueueAction :: DB.Connection -> RcvQueue -> Maybe RcvQueueAction -> IO ()
+setRcvQueueAction db RcvQueue {server = (SMPServer host port _), rcvId} rqAction_ = do
+  ts <- getCurrentTime
+  DB.execute
+    db
+    [sql|
+      UPDATE rcv_queues
+      SET rcv_queue_action = ?, rcv_queue_action_ts = ?
+      WHERE host = ? AND port = ? AND rcv_id = ? AND curr_rcv_queue = ?
+    |]
+    (rqAction_, ts, host, port, rcvId, True)
+
+switchCurrRcvQueue :: DB.Connection -> RcvQueue -> RcvQueue -> IO ()
+switchCurrRcvQueue db RcvQueue {server = (SMPServer host port _), rcvId} RcvQueue {dbNextRcvQueueId} = do
+  DB.execute db "DELETE FROM rcv_queues WHERE host = ? AND port = ? AND rcv_id = ? AND curr_rcv_queue = ?" (host, port, rcvId, True)
+  DB.execute db "UPDATE rcv_queues SET curr_rcv_queue = ? WHERE rcv_queue_id = ? AND curr_rcv_queue = ?" (True, dbNextRcvQueueId, False)
+
+switchCurrSndQueue :: DB.Connection -> SndQueue -> IO ()
+switchCurrSndQueue db SndQueue {server = (SMPServer host port _), sndId, dbNextSndQueueId} = do
+  DB.execute db "DELETE FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND curr_snd_queue = ?" (host, port, sndId, True)
+  DB.execute db "UPDATE snd_queues SET curr_snd_queue = ? WHERE snd_queue_id = ? AND curr_snd_queue = ?" (True, dbNextSndQueueId, False)
+
+type SMPConfirmationRow = (SndPublicVerifyKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version)
+
+smpConfirmation :: SMPConfirmationRow -> SMPConfirmation
+smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) =
+  SMPConfirmation
+    { senderKey,
+      e2ePubKey,
+      connInfo,
+      smpReplyQueues = fromMaybe [] smpReplyQueues_,
+      smpClientVersion = fromMaybe 1 smpClientVersion_
+    }
+
 createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId)
-createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues}, ratchetState} =
+createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues, smpClientVersion}, ratchetState} =
   createWithRandomId gVar $ \confirmationId ->
     DB.execute
       db
       [sql|
         INSERT INTO conn_confirmations
-        (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, 0);
+        (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0);
       |]
-      (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues)
+      (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues, smpClientVersion)
 
 acceptConfirmation :: DB.Connection -> ConfirmationId -> ConnInfo -> IO (Either StoreError AcceptedConfirmation)
 acceptConfirmation db confirmationId ownConnInfo = do
@@ -395,17 +556,17 @@ acceptConfirmation db confirmationId ownConnInfo = do
     DB.query
       db
       [sql|
-        SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues
+        SELECT conn_id, ratchet_state, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version
         FROM conn_confirmations
         WHERE confirmation_id = ?;
       |]
       (Only confirmationId)
   where
-    confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_) =
+    confirmation ((connId, ratchetState) :. confRow) =
       AcceptedConfirmation
         { confirmationId,
           connId,
-          senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
+          senderConf = smpConfirmation confRow,
           ratchetState,
           ownConnInfo
         }
@@ -416,17 +577,17 @@ getAcceptedConfirmation db connId =
     DB.query
       db
       [sql|
-        SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, own_conn_info
+        SELECT confirmation_id, ratchet_state, own_conn_info, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version
         FROM conn_confirmations
         WHERE conn_id = ? AND accepted = 1;
       |]
       (Only connId)
   where
-    confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_, ownConnInfo) =
+    confirmation ((confirmationId, ratchetState, ownConnInfo) :. confRow) =
       AcceptedConfirmation
         { confirmationId,
           connId,
-          senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
+          senderConf = smpConfirmation confRow,
           ratchetState,
           ownConnInfo
         }
@@ -486,6 +647,10 @@ acceptInvitation db invitationId ownConnInfo =
       ":invitation_id" := invitationId
     ]
 
+unacceptInvitation :: DB.Connection -> InvitationId -> IO ()
+unacceptInvitation db invitationId =
+  DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only invitationId)
+
 deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ())
 deleteInvitation db contactConnId invId =
   getConn db contactConnId $>>= \case
@@ -530,21 +695,21 @@ getPendingMsgData db connId msgId = do
       DB.query
         db
         [sql|
-          SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts
+          SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts, s.curr_snd_queue
           FROM messages m
           JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
           WHERE m.conn_id = ? AND m.internal_id = ?
         |]
         (connId, msgId)
-    pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, InternalTs) -> PendingMsgData
-    pendingMsgData (msgType, msgFlags_, msgBody, internalTs) =
+    pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, InternalTs, Bool) -> PendingMsgData
+    pendingMsgData (msgType, msgFlags_, msgBody, internalTs, currSndQueue) =
       let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
-       in PendingMsgData {msgId, msgType, msgFlags, msgBody, internalTs}
+       in PendingMsgData {msgId, msgType, msgFlags, msgBody, internalTs, currSndQueue}
 
-getPendingMsgs :: DB.Connection -> ConnId -> IO [InternalId]
-getPendingMsgs db connId =
+getPendingMsgs :: DB.Connection -> ConnId -> Bool -> IO [InternalId]
+getPendingMsgs db connId current =
   map fromOnly
-    <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ?" (Only connId)
+    <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ? AND curr_snd_queue = ?" (connId, current)
 
 setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError SMP.MsgId)
 setMsgUserAck db connId agentMsgId = do
@@ -631,6 +796,54 @@ updateRatchet db connId rc skipped = do
         forM_ (M.assocs mks) $ \(msgN, mk) ->
           DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk)
 
+createCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> ACommand 'Client -> IO AsyncCmdId
+createCommand db connId (Just (SMPServer host port _)) command = do
+  DB.execute
+    db
+    "INSERT INTO commands (host, port, conn_id, command) VALUES (?, ?, ?, ?)"
+    (host, port, connId, serializeCommand command)
+  insertedRowId db
+createCommand db connId Nothing command = do
+  DB.execute
+    db
+    "INSERT INTO commands (conn_id, command) VALUES (?, ?)"
+    (connId, command)
+  insertedRowId db
+
+insertedRowId :: DB.Connection -> IO Int64
+insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
+
+getPendingCommands :: DB.Connection -> ConnId -> IO [(Maybe SMPServer, [AsyncCmdId])]
+getPendingCommands db connId = do
+  map (\ids -> (fst $ head ids, map snd ids)) . groupBy ((==) `on` fst) . map srvCmdId
+    <$> DB.query
+      db
+      [sql|
+        SELECT c.host, c.port, s.key_hash, c.command_id
+        FROM commands c
+        LEFT JOIN servers s ON s.host = c.host AND s.port = c.port
+        WHERE conn_id = ?
+        ORDER BY c.host, c.port, c.command_id ASC
+      |]
+      (Only connId)
+  where
+    srvCmdId (host, port, keyHash, cmdId) = (SMPServer <$> host <*> port <*> keyHash, cmdId)
+
+getPendingCommand :: DB.Connection -> AsyncCmdId -> IO (Either StoreError (ConnId, ACmd))
+getPendingCommand db msgId = do
+  firstRow pendingCmd SECmdNotFound $
+    DB.query
+      db
+      "SELECT conn_id, command FROM commands WHERE command_id = ?"
+      (Only msgId)
+  where
+    pendingCmd :: (ConnId, ACmd) -> (ConnId, ACmd)
+    pendingCmd (connId, commandStr) = (connId, commandStr)
+
+deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
+deleteCommand db cmdId =
+  DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
+
 createNtfToken :: DB.Connection -> NtfToken -> IO ()
 createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do
   upsertNtfServer_ db srv
@@ -931,6 +1144,10 @@ getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId}
     res (connId, Just rcvNtfDhSecret) = Right (connId, rcvNtfDhSecret)
     res _ = Left SEConnNotFound
 
+setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()
+setConnectionNtfs db connId enableNtfs =
+  DB.execute db "UPDATE connections SET enable_ntfs = ? WHERE conn_id = ?" (enableNtfs, connId)
+
 -- * Auxiliary helpers
 
 instance ToField QueueStatus where toField = toField . serializeQueueStatus
@@ -985,6 +1202,22 @@ instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList
 
 instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP
 
+instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode
+
+instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField RcvQueueAction where toField = toField . textEncode
+
+instance FromField RcvQueueAction where fromField = fromTextField_ textDecode
+
+instance ToField SndQueueAction where toField = toField . textEncode
+
+instance FromField SndQueueAction where fromField = fromTextField_ textDecode
+
+instance ToField (ACommand p) where toField = toField . serializeCommand
+
+instance FromField ACmd where fromField = blobFieldParser dbCommandP
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -1056,91 +1289,132 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
-insertRcvQueue_ dbConn connId RcvQueue {..} = do
+insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO Int64
+insertRcvQueue_ db connId RcvQueue {..} = do
+  qId <- newQueueId_ <$> DB.query_ db "SELECT rcv_queue_id FROM rcv_queues ORDER BY rcv_queue_id DESC LIMIT 1"
   DB.execute
-    dbConn
+    db
     [sql|
       INSERT INTO rcv_queues
-        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status) VALUES (?,?,?,?,?,?,?,?,?,?);
+        (rcv_queue_id, host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, curr_rcv_queue, smp_client_version, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
-    (host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
+    ((qId, host server, port server, rcvId, connId) :. (rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (currRcvQueue, smpClientVersion, createdAt, updatedAt))
+  pure qId
 
 -- * createSndConn helpers
 
-insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()
-insertSndQueue_ dbConn connId SndQueue {..} = do
+insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO Int64
+insertSndQueue_ db connId SndQueue {..} = do
+  qId <- newQueueId_ <$> DB.query_ db "SELECT snd_queue_id FROM snd_queues ORDER BY snd_queue_id DESC LIMIT 1"
   DB.execute
-    dbConn
+    db
     [sql|
       INSERT INTO snd_queues
-        (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status) VALUES (?,?,?,?,?, ?,?, ?,?);
+        (snd_queue_id, host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, curr_snd_queue, smp_client_version, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);
     |]
-    (host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
+    ((qId, host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) :. (currSndQueue, smpClientVersion, createdAt, updatedAt))
+  pure qId
+
+newQueueId_ :: [Only (Maybe Int64)] -> Int64
+newQueueId_ [] = 1
+newQueueId_ (Only maxId_ : _) = maybe 1 (+ 1) maxId_
 
 -- * getConn helpers
 
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
-getConn dbConn connId =
-  getConnData_ dbConn connId >>= \case
+getConn db connId =
+  getConnData db connId >>= \case
     Nothing -> pure $ Left SEConnNotFound
-    Just (connData, cMode) -> do
-      rQ <- getRcvQueueByConnId_ dbConn connId
-      sQ <- getSndQueueByConnId_ dbConn connId
-      pure $ case (rQ, sQ, cMode) of
-        (Just rcvQ, Just sndQ, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)
-        (Just rcvQ, Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)
-        (Nothing, Just sndQ, CMInvitation) -> Right $ SomeConn SCSnd (SndConnection connData sndQ)
-        (Just rcvQ, Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection connData rcvQ)
-        _ -> Left SEConnNotFound
+    Just (cData, cMode) -> do
+      rq_ <- getRcvQueueByConnId_ db connId
+      sq_ <- getSndQueueByConnId_ db connId
+      case (rq_, sq_, cMode) of
+        (Just rq, Just sq, CMInvitation) -> do
+          rq' <- getNextRcvQueue db rq
+          sq' <- getNextSndQueue db sq
+          pure . Right $ SomeConn SCDuplex (DuplexConnection cData rq sq rq' sq')
+        (Just rq, Nothing, CMInvitation) -> pure . Right $ SomeConn SCRcv (RcvConnection cData rq)
+        (Nothing, Just sq, CMInvitation) -> pure . Right $ SomeConn SCSnd (SndConnection cData sq)
+        (Just rq, Nothing, CMContact) -> pure . Right $ SomeConn SCContact (ContactConnection cData rq)
+        (Nothing, Nothing, _) -> pure . Right $ SomeConn SCNew (NewConnection cData)
+        _ -> pure $ Left SEConnNotFound
 
-getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
-getConnData_ dbConn connId' =
-  connData
-    <$> DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, duplex_handshake FROM connections WHERE conn_id = ?;" (Only connId')
+getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
+getConnData dbConn connId' =
+  maybeFirstRow toConnData $
+    DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake FROM connections WHERE conn_id = ?;" (Only connId')
   where
-    connData [(connId, cMode, connAgentVersion, duplexHandshake)] = Just (ConnData {connId, connAgentVersion, duplexHandshake}, cMode)
-    connData _ = Nothing
+    toConnData (connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake) = (ConnData {connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake}, cMode)
+
+type RcvQueueRow =
+  ServerRow
+    :. (SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, Maybe C.APublicVerifyKey, QueueStatus)
+    :. (Maybe RcvQueueAction, Maybe UTCTime, Bool, Maybe Int64)
+    :. NtfCredsRow
+    :. (Maybe Version, UTCTime, UTCTime)
+
+type ServerRow = (NonEmpty TransportHost, String, C.KeyHash)
+
+type NtfCredsRow = (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret)
+
+toRcvQueue :: RcvQueueRow -> RcvQueue
+toRcvQueue (srvRow :. (rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndPublicKey, status) :. (rqAction_, rqActionTs_, currRcvQueue, dbNextRcvQueueId) :. ntfCredsRow :. (smpClientVersion_, createdAt, updatedAt)) =
+  let server = toSMPServer srvRow
+      smpClientVersion = fromMaybe 1 smpClientVersion_
+      rcvQueueAction = (,) <$> rqAction_ <*> rqActionTs_
+      clientNtfCreds = toNtfCreds ntfCredsRow
+   in RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndPublicKey, status, rcvQueueAction, currRcvQueue, dbNextRcvQueueId, smpClientVersion, clientNtfCreds, createdAt, updatedAt}
+
+toSMPServer :: ServerRow -> SMPServer
+toSMPServer (host, port, keyHash) = SMPServer host port keyHash
+
+toNtfCreds :: NtfCredsRow -> Maybe ClientNtfCreds
+toNtfCreds (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) = Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
+toNtfCreds _ = Nothing
 
 getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)
 getRcvQueueByConnId_ dbConn connId =
-  listToMaybe . map rcvQueue
-    <$> DB.query
+  maybeFirstRow toRcvQueue $
+    DB.query
       dbConn
       [sql|
-        SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
-          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
-          q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
+        SELECT q.host, q.port, s.key_hash,
+          q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_key, q.status,
+          q.rcv_queue_action, q.rcv_queue_action_ts, q.curr_rcv_queue, q.next_rcv_queue_id,
+          q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
+          q.smp_client_version, q.created_at, q.updated_at
         FROM rcv_queues q
         INNER JOIN servers s ON q.host = s.host AND q.port = s.port
-        WHERE q.conn_id = ?;
+        WHERE q.conn_id = ? AND q.curr_rcv_queue = ?
       |]
-      (Only connId)
-  where
-    rcvQueue ((keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
-      let server = SMPServer host port keyHash
-          clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
-            (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
-            _ -> Nothing
-       in RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, clientNtfCreds}
+      (connId, True)
 
 getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
-getSndQueueByConnId_ dbConn connId =
-  sndQueue
-    <$> DB.query
-      dbConn
+getSndQueueByConnId_ db connId =
+  maybeFirstRow toSndQueue $
+    DB.query
+      db
       [sql|
-        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status
+        SELECT q.host, q.port, s.key_hash,
+          q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
+          q.snd_queue_action, q.snd_queue_action_ts, q.curr_snd_queue, q.next_snd_queue_id,
+          q.smp_client_version, q.created_at, q.updated_at
         FROM snd_queues q
         INNER JOIN servers s ON q.host = s.host AND q.port = s.port
-        WHERE q.conn_id = ?;
+        WHERE q.conn_id = ? AND q.curr_snd_queue = ?
       |]
-      (Only connId)
-  where
-    sndQueue [(keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)] =
-      let server = SMPServer host port keyHash
-       in Just SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status}
-    sndQueue _ = Nothing
+      (connId, True)
+
+type SndQueueRow =
+  ServerRow
+    :. (SMP.SenderId, Maybe C.APublicVerifyKey, SMP.SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus, Maybe SndQueueAction, Maybe UTCTime, Bool, Maybe Int64)
+    :. (Version, UTCTime, UTCTime)
+
+toSndQueue :: SndQueueRow -> SndQueue
+toSndQueue (srvRow :. (sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, sqAction_, sqActionTs_, currSndQueue, dbNextSndQueueId) :. (smpClientVersion, createdAt, updatedAt)) =
+  let server = toSMPServer srvRow
+      sndQueueAction = (,) <$> sqAction_ <*> sqActionTs_
+   in SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, sndQueueAction, currSndQueue, dbNextSndQueueId, smpClientVersion, createdAt, updatedAt}
 
 -- * updateRcvIds helpers
 
@@ -1295,15 +1569,16 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} =
     dbConn
     [sql|
       INSERT INTO snd_messages
-        ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash)
+        ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash, curr_snd_queue)
       VALUES
-        (:conn_id,:internal_snd_id,:internal_id,:internal_hash,:previous_msg_hash);
+        (:conn_id,:internal_snd_id,:internal_id,:internal_hash,:previous_msg_hash,:curr_snd_queue);
     |]
     [ ":conn_id" := connId,
       ":internal_snd_id" := internalSndId,
       ":internal_id" := internalId,
       ":internal_hash" := internalHash,
-      ":previous_msg_hash" := prevMsgHash
+      ":previous_msg_hash" := prevMsgHash,
+      ":curr_snd_queue" := currSndQueue
     ]
 
 updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()

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

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

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

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

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

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

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

@@ -0,0 +1,61 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220822_queue_rotation where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20220822_queue_rotation :: Query
+m20220822_queue_rotation =
+  [sql|
+-- * rcv_queues
+
+ALTER TABLE rcv_queues ADD COLUMN rcv_queue_id INTEGER NULL;
+ALTER TABLE rcv_queues ADD COLUMN rcv_queue_action TEXT NULL;
+ALTER TABLE rcv_queues ADD COLUMN rcv_queue_action_ts TEXT NULL;
+
+ALTER TABLE rcv_queues ADD COLUMN curr_rcv_queue INTEGER CHECK (curr_rcv_queue NOT NULL);
+UPDATE rcv_queues SET curr_rcv_queue = 1;
+
+ALTER TABLE rcv_queues ADD COLUMN next_rcv_queue_id INTEGER NULL;
+  -- REFERENCES rcv_queues (rcv_queue_id) ON DELETE SET NULL;
+-- next_rcv_queue = 1: this is the new queue the connection is switching to
+-- next_rcv_queue_id: the ID of the next queue
+
+ALTER TABLE rcv_queues ADD COLUMN created_at TEXT CHECK (created_at NOT NULL);
+UPDATE rcv_queues SET created_at = '1970-01-01 00:00:00';
+
+ALTER TABLE rcv_queues ADD COLUMN updated_at TEXT CHECK (updated_at NOT NULL);
+UPDATE rcv_queues SET updated_at = '1970-01-01 00:00:00';
+
+CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(rcv_queue_id);
+CREATE UNIQUE INDEX idx_next_rcv_queue_id ON rcv_queues(next_rcv_queue_id);
+
+-- * snd_queues
+
+ALTER TABLE snd_queues ADD COLUMN snd_queue_id INTEGER NULL;
+ALTER TABLE snd_queues ADD COLUMN snd_queue_action TEXT NULL;
+ALTER TABLE snd_queues ADD COLUMN snd_queue_action_ts TEXT NULL;
+
+ALTER TABLE snd_queues ADD COLUMN curr_snd_queue INTEGER CHECK (curr_snd_queue NOT NULL);
+UPDATE snd_queues SET curr_snd_queue = 1;
+
+ALTER TABLE snd_queues ADD COLUMN next_snd_queue_id INTEGER NULL;
+  -- REFERENCES snd_queues (snd_queue_id) ON DELETE SET NULL;
+-- next_snd_queue = 1: this is the new queue the connection is switching to
+-- next_snd_queue_id: the ID of the next queue
+
+ALTER TABLE snd_queues ADD COLUMN created_at TEXT CHECK (created_at NOT NULL);
+UPDATE snd_queues SET created_at = '1970-01-01 00:00:00';
+
+ALTER TABLE snd_queues ADD COLUMN updated_at TEXT CHECK (updated_at NOT NULL);
+UPDATE snd_queues SET updated_at = '1970-01-01 00:00:00';
+
+CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(snd_queue_id);
+CREATE UNIQUE INDEX idx_next_snd_queue_id ON snd_queues(next_snd_queue_id);
+
+-- * 
+
+ALTER TABLE snd_messages ADD COLUMN curr_snd_queue INTEGER CHECK (curr_snd_queue NOT NULL);
+UPDATE snd_messages SET curr_snd_queue = 1;
+|]

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

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

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

@@ -20,7 +20,8 @@ CREATE TABLE connections(
   last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
   smp_agent_version INTEGER NOT NULL DEFAULT 1
   ,
-  duplex_handshake INTEGER NULL DEFAULT 0
+  duplex_handshake INTEGER NULL DEFAULT 0,
+  enable_ntfs INTEGER
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -40,6 +41,13 @@ CREATE TABLE rcv_queues(
   ntf_private_key BLOB,
   ntf_id BLOB,
   rcv_ntf_dh_secret BLOB,
+  rcv_queue_id INTEGER NULL,
+  rcv_queue_action TEXT NULL,
+  rcv_queue_action_ts TEXT NULL,
+  curr_rcv_queue INTEGER CHECK(curr_rcv_queue NOT NULL),
+  next_rcv_queue_id INTEGER NULL,
+  created_at TEXT CHECK(created_at NOT NULL),
+  updated_at TEXT CHECK(updated_at NOT NULL),
   PRIMARY KEY(host, port, rcv_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -57,6 +65,13 @@ CREATE TABLE snd_queues(
   smp_client_version INTEGER NOT NULL DEFAULT 1,
   snd_public_key BLOB,
   e2e_pub_key BLOB,
+  snd_queue_id INTEGER NULL,
+  snd_queue_action TEXT NULL,
+  snd_queue_action_ts TEXT NULL,
+  curr_snd_queue INTEGER CHECK(curr_snd_queue NOT NULL),
+  next_snd_queue_id INTEGER NULL,
+  created_at TEXT CHECK(created_at NOT NULL),
+  updated_at TEXT CHECK(updated_at NOT NULL),
   PRIMARY KEY(host, port, snd_id),
   FOREIGN KEY(host, port) REFERENCES servers
   ON DELETE RESTRICT ON UPDATE CASCADE
@@ -98,6 +113,7 @@ CREATE TABLE snd_messages(
   internal_id INTEGER NOT NULL,
   internal_hash BLOB NOT NULL,
   previous_msg_hash BLOB NOT NULL DEFAULT x'',
+  curr_snd_queue INTEGER CHECK(curr_snd_queue NOT NULL),
   PRIMARY KEY(conn_id, internal_snd_id),
   FOREIGN KEY(conn_id, internal_id) REFERENCES messages
   ON DELETE CASCADE
@@ -113,7 +129,8 @@ CREATE TABLE conn_confirmations(
   own_conn_info BLOB,
   created_at TEXT NOT NULL DEFAULT(datetime('now'))
   ,
-  smp_reply_queues BLOB NULL
+  smp_reply_queues BLOB NULL,
+  smp_client_version INTEGER
 ) WITHOUT ROWID;
 CREATE TABLE conn_invitations(
   invitation_id BLOB NOT NULL PRIMARY KEY,
@@ -192,3 +209,17 @@ CREATE TABLE ntf_subscriptions(
   FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers
   ON DELETE RESTRICT ON UPDATE CASCADE
 ) WITHOUT ROWID;
+CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(rcv_queue_id);
+CREATE UNIQUE INDEX idx_next_rcv_queue_id ON rcv_queues(next_rcv_queue_id);
+CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(snd_queue_id);
+CREATE UNIQUE INDEX idx_next_snd_queue_id ON snd_queues(next_snd_queue_id);
+CREATE TABLE commands(
+  command_id INTEGER PRIMARY KEY,
+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
+  host TEXT,
+  port TEXT,
+  command TEXT NOT NULL,
+  command_version INTEGER NOT NULL DEFAULT 1,
+  FOREIGN KEY(host, port) REFERENCES servers
+  ON DELETE RESTRICT ON UPDATE CASCADE
+);

src/Simplex/Messaging/Client.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -24,7 +26,7 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
-    ProtocolClient (thVersion, sessionId),
+    ProtocolClient (thVersion, sessionId, transportHost),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
@@ -32,11 +34,14 @@ module Simplex.Messaging.Client
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
+    subscribeSMPQueues,
     getSMPMessage,
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
     disableSMPQueueNotifications,
+    enableSMPQueuesNtfs,
+    disableSMPQueuesNtfs,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
@@ -46,7 +51,10 @@ module Simplex.Messaging.Client
     -- * Supporting types and client configuration
     ProtocolClientError (..),
     ProtocolClientConfig (..),
+    NetworkConfig (..),
     defaultClientConfig,
+    defaultNetworkConfig,
+    chooseTransportHost,
     ServerTransmission,
   )
 where
@@ -58,17 +66,27 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Either (rights)
+import Data.Functor (($>))
+import Data.List (find)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
+import Data.Word (Word16)
+import GHC.Generics (Generic)
 import Network.Socket (ServiceName)
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
 import Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (runTransportClient)
+import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
@@ -84,31 +102,82 @@ data ProtocolClient msg = ProtocolClient
     sessionId :: SessionId,
     thVersion :: Version,
     protocolServer :: ProtoServer msg,
+    transportHost :: TransportHost,
     tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TMap CorrId (Request msg),
-    sndQ :: TBQueue SentRawTransmission,
-    rcvQ :: TBQueue (SignedTransmission msg),
+    sndQ :: TBQueue (NonEmpty (SentRawTransmission)),
+    rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
     msgQ :: Maybe (TBQueue (ServerTransmission msg))
   }
 
 type SMPClient = ProtocolClient SMP.BrokerMsg
 
+-- | Type for client command data
+type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
+
 -- | Type synonym for transmission from some SPM server queue.
 type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
 
+data HostMode
+  = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
+    HMOnionViaSocks
+  | -- | prefer (or require) onion hosts
+    HMOnion
+  | -- | prefer (or require) public hosts
+    HMPublic
+  deriving (Eq, Show, Generic)
+
+instance FromJSON HostMode where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM"
+
+instance ToJSON HostMode where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM"
+
+-- | network configuration for the client
+data NetworkConfig = NetworkConfig
+  { -- | use SOCKS5 proxy
+    socksProxy :: Maybe SocksProxy,
+    -- | determines critera which host is chosen from the list
+    hostMode :: HostMode,
+    -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
+    requiredHostMode :: Bool,
+    -- | timeout for the initial client TCP/TLS connection (microseconds)
+    tcpConnectTimeout :: Int,
+    -- | timeout of protocol commands (microseconds)
+    tcpTimeout :: Int,
+    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
+    tcpKeepAlive :: Maybe KeepAliveOpts,
+    -- | period for SMP ping commands (microseconds)
+    smpPingInterval :: Int
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON NetworkConfig where
+  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
+  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+
+defaultNetworkConfig :: NetworkConfig
+defaultNetworkConfig =
+  NetworkConfig
+    { socksProxy = Nothing,
+      hostMode = HMOnionViaSocks,
+      requiredHostMode = False,
+      tcpConnectTimeout = 7_500_000,
+      tcpTimeout = 5_000_000,
+      tcpKeepAlive = Just defaultKeepAliveOpts,
+      smpPingInterval = 600_000_000 -- 10min
+    }
+
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
     -- | default server port if port is not specified in ProtocolServer
     defaultTransport :: (ServiceName, ATransport),
-    -- | timeout of TCP commands (microseconds)
-    tcpTimeout :: Int,
-    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    -- | period for SMP ping commands (microseconds)
-    smpPing :: Int,
+    -- | network configuration
+    networkConfig :: NetworkConfig,
     -- | SMP client-server protocol version range
     smpServerVRange :: VersionRange
   }
@@ -119,9 +188,7 @@ defaultClientConfig =
   ProtocolClientConfig
     { qSize = 64,
       defaultTransport = ("443", transport @TLS),
-      tcpTimeout = 5_000_000,
-      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPing = 600_000_000, -- 10min
+      networkConfig = defaultNetworkConfig,
       smpServerVRange = supportedSMPServerVRange
     }
 
@@ -132,18 +199,36 @@ data Request msg = Request
 
 type Response msg = Either ProtocolClientError msg
 
+chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError TransportHost
+chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
+  firstOrError $ case hostMode of
+    HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
+    HMOnion -> onionHost
+    HMPublic -> publicHost
+  where
+    firstOrError
+      | requiredHostMode = maybe (Left PCEIncompatibleHost) Right
+      | otherwise = Right . fromMaybe (L.head hosts)
+    isOnionHost = \case THOnionHost _ -> True; _ -> False
+    onionHost = find isOnionHost hosts
+    publicHost = find (not . isOnionHost) hosts
+
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
-getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
-  (atomically mkProtocolClient >>= runClient useTransport)
-    `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
+getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
+  case chooseTransportHost networkConfig (host protocolServer) of
+    Right useHost ->
+      (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
+        `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
+    Left e -> pure $ Left e
   where
-    mkProtocolClient :: STM (ProtocolClient msg)
-    mkProtocolClient = do
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpKeepAlive, socksProxy, smpPingInterval} = networkConfig
+    mkProtocolClient :: TransportHost -> STM (ProtocolClient msg)
+    mkProtocolClient transportHost = do
       connected <- newTVar False
       clientCorrId <- newTVar 0
       sentCommands <- TM.empty
@@ -156,6 +241,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
             thVersion = undefined,
             connected,
             protocolServer,
+            transportHost,
             tcpTimeout,
             clientCorrId,
             sentCommands,
@@ -164,14 +250,14 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
-    runClient (port', ATransport t) c = do
+    runClient :: (ServiceName, ATransport) -> TransportHost -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
+    runClient (port', ATransport t) useHost c = do
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
+          runTransportClient socksProxy useHost port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
             `finally` atomically (putTMVar thVar $ Left PCENetworkError)
-      th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
+      th_ <- tcpConnectTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case th_ of
         Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
         Just (Left e) -> Left e
@@ -194,7 +280,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
           let c' = c {sessionId, thVersion} :: ProtocolClient msg
           -- TODO remove ping if 0 is passed (or Nothing?)
           raceAny_ [send c' th, process c', receive c' th, ping c']
-            `finally` disconnected
+            `finally` disconnected c'
 
     send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
     send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
@@ -204,17 +290,19 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
 
     ping :: ProtocolClient msg -> IO ()
     ping c = forever $ do
-      threadDelay smpPing
+      threadDelay smpPingInterval
       runExceptT $ sendProtocolCommand c Nothing "" protocolPing
 
     process :: ProtocolClient msg -> IO ()
-    process c@ProtocolClient {rcvQ, sentCommands} = forever $ do
-      (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
+    process c = forever $ atomically (readTBQueue $ rcvQ c) >>= mapM_ (processMsg c)
+
+    processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
+    processMsg c@ProtocolClient {sentCommands} (_, _, (corrId, qId, respOrErr)) =
       if B.null $ bs corrId
-        then sendMsg qId respOrErr
+        then sendMsg respOrErr
         else do
           atomically (TM.lookup corrId sentCommands) >>= \case
-            Nothing -> sendMsg qId respOrErr
+            Nothing -> sendMsg respOrErr
             Just Request {queueId, responseVar} -> atomically $ do
               TM.delete corrId sentCommands
               putTMVar responseVar $
@@ -226,8 +314,8 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
                       _ -> Right r
                   else Left . PCEUnexpectedResponse $ bshow respOrErr
       where
-        sendMsg :: QueueId -> Either ErrorType msg -> IO ()
-        sendMsg qId = \case
+        sendMsg :: Either 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 ()
@@ -255,6 +343,8 @@ data ProtocolClientError
   | -- | Failure to establish TCP connection.
     -- Forwarded to the agent client as `ERR BROKER NETWORK`.
     PCENetworkError
+  | -- | No host compatible with network configuration
+    PCEIncompatibleHost
   | -- | TCP transport handshake or some other transport error.
     -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
     PCETransportError TransportError
@@ -285,12 +375,28 @@ subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT Pr
 subscribeSMPQueue c rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
-    cmd@MSG {} -> writeSMPMessage c rId cmd
+    cmd@MSG {} -> deliver cmd
+    cmd@LEN {} -> deliver cmd
     r -> throwE . PCEUnexpectedResponse $ bshow r
+  where
+    deliver = liftIO . writeSMPMessage c rId
 
-writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> ExceptT ProtocolClientError IO ()
-writeSMPMessage c rId msg =
-  liftIO . atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
+-- | Subscribe to multiple SMP queues batching commands if supported.
+subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
+subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
+  where
+    cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
+    response ((_, rId), r) = case r of
+      Right OK -> pure $ Right ()
+      Right cmd@MSG {} -> deliver cmd
+      Right cmd@LEN {} -> deliver cmd
+      Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
+      Left e -> pure $ Left e
+      where
+        deliver cmd = writeSMPMessage c rId cmd $> Right ()
+
+writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
+writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
 
 serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
 serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
@@ -303,10 +409,11 @@ getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT Protoc
 getSMPMessage c rpKey rId =
   sendSMPCommand c (Just rpKey) rId GET >>= \case
     OK -> pure Nothing
-    cmd@(MSG msg) -> do
-      writeSMPMessage c rId cmd
-      pure $ Just msg
+    cmd@(MSG msg) -> deliver cmd $> Just msg
+    cmd@LEN {} -> deliver cmd $> Nothing
     r -> throwE . PCEUnexpectedResponse $ bshow r
+  where
+    deliver = liftIO . writeSMPMessage c rId
 
 -- | Subscribe to the SMP queue notifications.
 --
@@ -329,12 +436,32 @@ enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
     NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
+-- | Enable notifications for the multiple queues for push notifications server.
+enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
+enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
+  where
+    cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
+    response = \case
+      Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
+      Right r -> Left . PCEUnexpectedResponse $ bshow r
+      Left e -> Left e
+
 -- | Disable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
 disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
 disableSMPQueueNotifications = 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
+
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
@@ -351,15 +478,21 @@ ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT P
 ackSMPMessage c rpKey rId msgId =
   sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
-    cmd@MSG {} -> writeSMPMessage c rId cmd
+    cmd@MSG {} -> deliver cmd
+    cmd@LEN {} -> deliver cmd
     r -> throwE . PCEUnexpectedResponse $ bshow r
+  where
+    deliver = liftIO . writeSMPMessage c rId
 
 -- | Irreversibly suspend SMP queue.
 -- The existing messages from the queue will still be delivered.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
-suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
-suspendSMPQueue = okSMPCommand OFF
+suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO Word16
+suspendSMPQueue c pKey qId =
+  sendSMPCommand c (Just pKey) qId OFF >>= \case
+    LEN len -> return len
+    r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Irreversibly delete SMP queue and all messages in it.
 --
@@ -377,37 +510,48 @@ okSMPCommand cmd c pKey qId =
 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
+  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
+    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 ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, thVersion, tcpTimeout} pKey qId cmd = do
-  corrId <- lift_ getNextCorrId
-  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
-  ExceptT $ sendRecv corrId t
+sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
+  (t, r) <- mkTransmission c (pKey, qId, cmd)
+  ExceptT $ sendRecv t r
   where
-    lift_ :: STM a -> ExceptT ProtocolClientError IO a
-    lift_ action = ExceptT $ Right <$> atomically action
+    -- 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
 
+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
+  corrId <- liftIO $ atomically getNextCorrId
+  t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
+  r <- liftIO . atomically $ mkRequest corrId
+  pure (t, r)
+  where
     getNextCorrId :: STM CorrId
     getNextCorrId = do
       i <- stateTVar clientCorrId $ \i -> (i, i + 1)
       pure . CorrId $ bshow i
-
     signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
     signTransmission t = case pKey of
-      Nothing -> return (Nothing, t)
+      Nothing -> pure (Nothing, t)
       Just pk -> do
         sig <- liftError PCESignatureError $ C.sign pk t
         return (Just sig, t)
-
-    -- two separate "atomically" needed to avoid blocking
-    sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
-    sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
-      where
-        withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
-
-    send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
-    send corrId t = do
+    mkRequest :: CorrId -> STM (TMVar (Response msg))
+    mkRequest corrId = do
       r <- newEmptyTMVar
       TM.insert corrId (Request qId r) sentCommands
-      writeTBQueue sndQ t
-      return r
+      pure r

src/Simplex/Messaging/Client/Agent.hs

@@ -26,6 +26,7 @@ import Numeric.Natural
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -125,8 +126,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
 
     waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
     waitForSMPClient smpVar = do
-      let ProtocolClientConfig {tcpTimeout} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
+      let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
+      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
       liftEither $ case smpClient_ of
         Just (Right smpClient) -> Right smpClient
         Just (Left e) -> Left e
@@ -161,8 +162,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
     connectClient :: ExceptT ProtocolClientError IO SMPClient
     connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
-    clientDisconnected :: IO ()
-    clientDisconnected = do
+    clientDisconnected :: SMPClient -> IO ()
+    clientDisconnected _ = do
       removeClientAndSubs >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
@@ -264,7 +265,7 @@ subscribeQueue ca srv sub = do
 
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
-  B.pack $ host <> if null port then "" else ':' : port
+  strEncode host <> (B.pack $ if null port then "" else ':' : port)
 
 smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
 smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId

src/Simplex/Messaging/Encoding.hs

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

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -23,6 +23,7 @@ import Data.Type.Equality
 import Data.Word (Word16)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -332,12 +333,16 @@ data SMPQueueNtf = SMPQueueNtf
 instance Encoding SMPQueueNtf where
   smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
   smpP = do
-    (smpServer, notifierId) <- smpP
-    pure $ SMPQueueNtf {smpServer, notifierId}
+    smpServer <- updateSMPServerHosts <$> smpP
+    notifierId <- smpP
+    pure SMPQueueNtf {smpServer, notifierId}
 
 instance StrEncoding SMPQueueNtf where
   strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
-  strP = SMPQueueNtf <$> strP <* A.char '/' <*> strP
+  strP = do
+    smpServer <- updateSMPServerHosts <$> strP
+    notifierId <- A.char '/' *> strP
+    pure SMPQueueNtf {smpServer, notifierId}
 
 data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
   deriving (Eq, Ord, Show)

src/Simplex/Messaging/Notifications/Server.hs

@@ -4,7 +4,10 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -17,30 +20,41 @@ import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Crypto.Random (MonadRandom)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import Data.List (intercalate)
 import Data.Map.Strict (Map)
 import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Network.Socket (ServiceName)
 import Simplex.Messaging.Client (ProtocolClientError (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
+import Simplex.Messaging.Server.Stats
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
 import Simplex.Messaging.Transport.Server (runTransportServer)
 import Simplex.Messaging.Util
+import System.Exit (exitFailure)
+import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
 import System.Mem.Weak (deRefWeak)
-import UnliftIO (IOMode (..), async, uninterruptibleCancel)
+import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
 import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
+import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
 import UnliftIO.STM
 
@@ -53,12 +67,13 @@ runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfSer
 runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
 
 ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfig -> TMVar Bool -> m ()
-ntfServer NtfServerConfig {transports} started = do
+ntfServer cfg@NtfServerConfig {transports} started = do
+  restoreServerStats
   s <- asks subscriber
   ps <- asks pushServer
   subs <- readTVarIO =<< asks (subscriptions . store)
   void . forkIO $ resubscribe s subs
-  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports) `finally` stopServer
+  raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
   where
     runServer :: (ServiceName, ATransport) -> m ()
     runServer (tcpPort, ATransport t) = do
@@ -75,8 +90,55 @@ ntfServer NtfServerConfig {transports} started = do
     stopServer :: m ()
     stopServer = do
       withNtfLog closeStoreLog
+      saveServerStats
       asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
 
+    serverStatsThread_ :: NtfServerConfig -> [m ()]
+    serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
+      [logServerStats logStatsStartTime interval serverStatsLogFile]
+    serverStatsThread_ _ = []
+
+    logServerStats :: Int -> Int -> FilePath -> m ()
+    logServerStats startAt logInterval statsFilePath = do
+      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
+      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
+      threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
+      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
+      let interval = 1000000 * logInterval
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
+          ts <- getCurrentTime
+          fromTime' <- atomically $ swapTVar fromTime ts
+          tknCreated' <- atomically $ swapTVar tknCreated 0
+          tknVerified' <- atomically $ swapTVar tknVerified 0
+          tknDeleted' <- atomically $ swapTVar tknDeleted 0
+          subCreated' <- atomically $ swapTVar subCreated 0
+          subDeleted' <- atomically $ swapTVar subDeleted 0
+          ntfReceived' <- atomically $ swapTVar ntfReceived 0
+          ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
+          tkn <- atomically $ periodStatCounts activeTokens ts
+          sub <- atomically $ periodStatCounts activeSubs ts
+          hPutStrLn h $
+            intercalate
+              ","
+              [ iso8601Show $ utctDay fromTime',
+                show tknCreated',
+                show tknVerified',
+                show tknDeleted',
+                show subCreated',
+                show subDeleted',
+                show ntfReceived',
+                show ntfDelivered',
+                dayCount tkn,
+                weekCount tkn,
+                monthCount tkn,
+                dayCount sub,
+                weekCount sub,
+                monthCount sub
+              ]
+          threadDelay interval
+
 resubscribe :: (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> m ()
 resubscribe NtfSubscriber {newSubQ} subs = do
   d <- asks $ resubscribeDelay . config
@@ -136,9 +198,12 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
           ntfTs <- liftIO getSystemTime
           st <- asks store
           NtfPushServer {pushQ} <- asks pushServer
+          stats <- asks serverStats
+          atomically $ updatePeriodStats (activeSubs stats) ntfId
           atomically $
             findNtfSubscriptionToken st smpQueue
               >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
+          incNtfStat ntfReceived
         SMP.END -> updateSubStatus smpQueue NSEnd
         _ -> pure ()
       pure ()
@@ -148,19 +213,21 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
         atomically (readTBQueue agentQ) >>= \case
           CAConnected _ -> pure ()
           CADisconnected srv subs -> do
-            logInfo . T.pack $ "SMP server disconnected " <> host srv <> " (" <> show (length subs) <> ") subscriptions"
+            logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
             forM_ subs $ \(_, ntfId) -> do
               let smpQueue = SMPQueueNtf srv ntfId
               updateSubStatus smpQueue NSInactive
           CAReconnected srv ->
-            logInfo $ "SMP server reconnected " <> T.pack (host srv)
+            logInfo $ "SMP server reconnected " <> showServer' srv
           CAResubscribed srv sub -> do
             let ntfId = snd sub
                 smpQueue = SMPQueueNtf srv ntfId
             updateSubStatus smpQueue NSActive
           CASubError srv (_, ntfId) err -> do
-            logError . T.pack $ "SMP subscription error on server " <> host srv <> ": " <> show err
+            logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
             handleSubError (SMPQueueNtf srv ntfId) err
+      where
+        showServer' = decodeLatin1 . strEncode . host
 
     handleSubError :: SMPQueueNtf -> ProtocolClientError -> m ()
     handleSubError smpQueue = \case
@@ -171,6 +238,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
       PCETransportError e -> updateErr "TransportError " e
       PCESignatureError e -> updateErr "SignatureError " e
+      PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
       PCEResponseTimeout -> pure ()
       PCENetworkError -> pure ()
       where
@@ -192,18 +260,21 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
   liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
   status <- readTVarIO tknStatus
   case (status, ntf) of
-    (_, PNVerification _) -> do
+    (_, 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) -> do
+    (NTActive, PNCheckMessages) ->
       void $ deliverNotification pp tkn ntf
     (NTActive, PNMessage {}) -> do
+      stats <- asks serverStats
+      atomically $ updatePeriodStats (activeTokens stats) ntfTknId
       void $ deliverNotification pp tkn ntf
-    _ -> do
+      incNtfStat ntfDelivered
+    _ ->
       liftIO $ logError "bad notification token status"
   where
     deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> m (Either PushProviderError ())
@@ -248,22 +319,23 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte
 
 receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
 receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
-  t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
-  atomically . writeTVar activeAt =<< liftIO getSystemTime
-  logDebug "received transmission"
-  case cmdOrError of
-    Left e -> write sndQ (corrId, entId, NRErr e)
-    Right cmd ->
-      verifyNtfTransmission t cmd >>= \case
-        VRVerified req -> write rcvQ req
-        VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
+  ts <- tGet th
+  forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
+    atomically . writeTVar activeAt =<< liftIO getSystemTime
+    logDebug "received transmission"
+    case cmdOrError of
+      Left e -> write sndQ (corrId, entId, NRErr e)
+      Right cmd ->
+        verifyNtfTransmission t cmd >>= \case
+          VRVerified req -> write rcvQ req
+          VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
   where
     write q t = atomically $ writeTBQueue q t
 
 send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
 send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
+  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
   atomically . writeTVar activeAt =<< liftIO getSystemTime
 
 -- instance Show a => Show (TVar a) where
@@ -345,6 +417,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         atomically $ addNtfToken st tknId tkn
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
         withNtfLog (`logCreateToken` tkn)
+        incNtfStat tknCreated
         pure (corrId, "", NRTknId tknId srvDhPubKey)
       NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
@@ -366,6 +439,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               tIds <- atomically $ removeInactiveTokenRegistrations st tkn
               forM_ tIds cancelInvervalNotifications
               withNtfLog $ \s -> logTokenStatus s tknId NTActive
+              incNtfStat tknVerified
               pure NROk
             | otherwise -> do
               logDebug "TVFY - incorrect code or token status"
@@ -384,6 +458,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               addNtfToken st tknId tkn'
               writeTBQueue pushQ (tkn', PNVerification regCode)
             withNtfLog $ \s -> logUpdateToken s tknId token' regCode
+            incNtfStat tknDeleted
+            incNtfStat tknCreated
             pure NROk
           TDEL -> do
             logDebug "TDEL"
@@ -393,6 +469,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             cancelInvervalNotifications tknId
             withNtfLog (`logDeleteToken` tknId)
+            incNtfStat tknDeleted
             pure NROk
           TCRN 0 -> do
             logDebug "TCRN 0"
@@ -432,6 +509,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             Just _ -> atomically (writeTBQueue newSubQ $ NtfSub sub) $> NRSubId subId
             _ -> pure $ NRErr AUTH
         withNtfLog (`logCreateSubscription` sub)
+        incNtfStat subCreated
         pure (corrId, "", resp)
       NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         status <- readTVarIO subStatus
@@ -452,6 +530,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             atomically $ deleteNtfSubscription st subId
             atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             withNtfLog (`logDeleteSubscription` subId)
+            incNtfStat subDeleted
             pure NROk
           PING -> pure NRPong
     getId :: m NtfEntityId
@@ -469,3 +548,33 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
 
 withNtfLog :: (MonadUnliftIO m, MonadReader NtfEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
 withNtfLog action = liftIO . mapM_ action =<< asks storeLog
+
+incNtfStat :: (MonadUnliftIO m, MonadReader NtfEnv m) => (NtfServerStats -> TVar Int) -> m ()
+incNtfStat statSel = do
+  stats <- asks serverStats
+  atomically $ modifyTVar (statSel stats) (+ 1)
+
+saveServerStats :: (MonadUnliftIO m, MonadReader NtfEnv m) => m ()
+saveServerStats =
+  asks (serverStatsBackupFile . config)
+    >>= mapM_ (\f -> asks serverStats >>= atomically . getNtfServerStatsData >>= liftIO . saveStats f)
+  where
+    saveStats f stats = do
+      logInfo $ "saving server stats to file " <> T.pack f
+      B.writeFile f $ strEncode stats
+      logInfo "server stats saved"
+
+restoreServerStats :: (MonadUnliftIO m, MonadReader NtfEnv m) => m ()
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
+  where
+    restoreStats f = whenM (doesFileExist f) $ do
+      logInfo $ "restoring server stats from file " <> T.pack f
+      liftIO (strDecode <$> B.readFile f) >>= \case
+        Right d -> do
+          s <- asks serverStats
+          atomically $ setNtfServerStats s d
+          renameFile f $ f <> ".bak"
+          logInfo "server stats restored"
+        Left e -> do
+          logInfo $ "error restoring server stats: " <> T.pack e
+          liftIO exitFailure

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

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

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

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

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

@@ -106,6 +106,7 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
       forM_ tIds $ \(regKey, tId') -> do
         TM.delete regKey tknRegs
         TM.delete tId' $ tokens st
+        -- TODO remove token subscriptions as in deleteNtfToken
       pure $ map snd tIds
 
 removeTokenRegistration :: NtfStore -> NtfTknData -> STM ()
@@ -130,6 +131,7 @@ deleteNtfToken st tknId = do
               )
       )
 
+  -- TODO refactor
   qs <-
     TM.lookupDelete tknId (tokenSubscriptions st)
       >>= mapM

src/Simplex/Messaging/Notifications/Transport.hs

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

src/Simplex/Messaging/Protocol.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
@@ -37,8 +38,7 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Protocol
   ( -- * SMP protocol parameters
-    smpClientVersion,
-    smpClientVRange,
+    supportedSMPClientVRange,
     maxMessageLength,
     e2eEncConfirmationLength,
     e2eEncMessageLength,
@@ -64,6 +64,8 @@ module Simplex.Messaging.Protocol
     PrivHeader (..),
     Protocol (..),
     ProtocolType (..),
+    AProtocolType (..),
+    ProtocolTypeI (..),
     ProtocolServer (..),
     ProtoServer,
     SMPServer,
@@ -110,6 +112,9 @@ module Simplex.Messaging.Protocol
     _smpP,
     encodeRcvMsgBody,
     clientRcvMsgBodyP,
+    legacyEncodeServer,
+    legacyServerP,
+    legacyStrEncodeServer,
 
     -- * TCP transport functions
     tPut,
@@ -130,10 +135,13 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Kind
-import Data.Maybe (isNothing)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
+import Data.Maybe (isJust, isNothing)
 import Data.String
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
+import Data.Word (Word16)
 import GHC.Generics (Generic)
 import GHC.TypeLits (type (+))
 import Generic.Random (genericArbitraryU)
@@ -143,15 +151,16 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
 import Simplex.Messaging.Util (bshow, (<$?>))
 import Simplex.Messaging.Version
 import Test.QuickCheck (Arbitrary (..))
 
-smpClientVersion :: Version
-smpClientVersion = 1
+currentSMPClientVersion :: Version
+currentSMPClientVersion = 2
 
-smpClientVRange :: VersionRange
-smpClientVRange = mkVersionRange 1 smpClientVersion
+supportedSMPClientVRange :: VersionRange
+supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
 
 maxMessageLength :: Int
 maxMessageLength = 16088
@@ -274,6 +283,7 @@ data BrokerMsg where
   NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
   NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
   END :: BrokerMsg
+  LEN :: Word16 -> BrokerMsg
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
   PONG :: BrokerMsg
@@ -428,6 +438,7 @@ data BrokerMsgTag
   | NID_
   | NMSG_
   | END_
+  | LEN_
   | OK_
   | ERR_
   | PONG_
@@ -487,6 +498,7 @@ instance Encoding BrokerMsgTag where
     NID_ -> "NID"
     NMSG_ -> "NMSG"
     END_ -> "END"
+    LEN_ -> "LEN"
     OK_ -> "OK"
     ERR_ -> "ERR"
     PONG_ -> "PONG"
@@ -499,6 +511,7 @@ instance ProtocolMsgTag BrokerMsgTag where
     "NID" -> Just NID_
     "NMSG" -> Just NMSG_
     "END" -> Just END_
+    "LEN" -> Just LEN_
     "OK" -> Just OK_
     "ERR" -> Just ERR_
     "PONG" -> Just PONG_
@@ -552,14 +565,14 @@ instance Encoding ClientMessage where
 
 type SMPServer = ProtocolServer 'PSMP
 
-pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
+pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
 pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
 
 {-# COMPLETE SMPServer #-}
 
 type NtfServer = ProtocolServer 'PNTF
 
-pattern NtfServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
+pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
 pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
 
 {-# COMPLETE NtfServer #-}
@@ -572,7 +585,7 @@ instance StrEncoding ProtocolType where
     PSMP -> "smp"
     PNTF -> "ntf"
   strP =
-    A.takeTill (== ':') >>= \case
+    A.takeTill (\c -> c == ':' || c == ' ') >>= \case
       "smp" -> pure PSMP
       "ntf" -> pure PNTF
       _ -> fail "bad ProtocolType"
@@ -589,6 +602,11 @@ deriving instance Show (SProtocolType p)
 
 data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
 
+deriving instance Show AProtocolType
+
+instance Eq AProtocolType where
+  AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
+
 instance TestEquality SProtocolType where
   testEquality SPSMP SPSMP = Just Refl
   testEquality SPNTF SPNTF = Just Refl
@@ -612,6 +630,10 @@ instance StrEncoding AProtocolType where
   strEncode (AProtocolType p) = strEncode p
   strP = aProtocolType <$> strP
 
+instance ToJSON AProtocolType where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
 checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
 checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
   Just Refl -> Right p
@@ -627,7 +649,7 @@ instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
   { scheme :: SProtocolType p,
-    host :: HostName,
+    host :: NonEmpty TransportHost,
     port :: ServiceName,
     keyHash :: C.KeyHash
   }
@@ -645,17 +667,39 @@ instance ProtocolTypeI p => Encoding (ProtocolServer p) where
 
 instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
   strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncode scheme <> "://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
+    strEncodeServer scheme (strEncode host) port keyHash
   strP = do
     scheme <- strP <* "://"
     keyHash <- strP <* A.char '@'
-    SrvLoc host port <- strP
+    TransportHosts host <- strP
+    port <- portP <|> pure ""
     pure ProtocolServer {scheme, host, port, keyHash}
+    where
+      portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
 instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+legacyEncodeServer :: ProtocolServer p -> ByteString
+legacyEncodeServer ProtocolServer {host, port, keyHash} =
+  smpEncode (L.head host, port, keyHash)
+
+legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
+legacyServerP = do
+  (h, port, keyHash) <- smpP
+  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}
+
+legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
+legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
+  strEncodeServer scheme (strEncode $ L.head host) port keyHash
+
+strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> ByteString
+strEncodeServer scheme host port keyHash =
+  strEncode scheme <> "://" <> strEncode keyHash <> "@" <> host <> portStr
+  where
+    portStr = B.pack $ if null port then "" else ':' : port
+
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
 
@@ -664,7 +708,7 @@ instance StrEncoding SrvLoc where
   strP = SrvLoc <$> host <*> (port <|> pure "")
     where
       host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
+      port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
 -- | Transmission correlation ID.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
@@ -906,6 +950,7 @@ instance ProtocolEncoding BrokerMsg where
     NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
     NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
     END -> e END_
+    LEN len -> e (LEN_, ' ', len)
     OK -> e OK_
     ERR err -> e (ERR_, ' ', err)
     PONG -> e PONG_
@@ -926,6 +971,7 @@ instance ProtocolEncoding BrokerMsg where
     NID_ -> NID <$> _smpP <*> smpP
     NMSG_ -> NMSG <$> _smpP <*> smpP
     END_ -> pure END
+    LEN_ -> LEN <$> _smpP
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP
     PONG_ -> pure PONG
@@ -1010,20 +1056,51 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
-tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
+tPut :: Transport c => THandle c -> NonEmpty (SentRawTransmission) -> IO (NonEmpty (Either TransportError ()))
+tPut th trs
+  | batch th = tPutBatch [] $ L.map tEncode trs
+  | otherwise = forM trs $ tPutBlock th . tEncode
+  where
+    tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO (NonEmpty (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)
+      let rs' = rs <> r
+      case ts_ of
+        Just ts' -> tPutBatch rs' ts'
+        _ -> pure $ L.fromList rs'
+    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
+              then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
+              else case L.nonEmpty ts_ of
+                Just ts' -> encodeBatch n' s' ts'
+                _ -> (n', s', Nothing)
+    tEncode (sig, tr) = smpEncode (C.signatureBytes sig) <> tr
 
 encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
 encodeTransmission v sessionId (CorrId corrId, queueId, command) =
   smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
 
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
-tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
-tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
+tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
+tGetParse th
+  | batch th = either ((:| []) . Left) id <$> runExceptT getBatch
+  | otherwise = (:| []) . (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
+  where
+    getBatch :: ExceptT TransportError IO (NonEmpty (Either TransportError RawTransmission))
+    getBatch = do
+      s <- ExceptT $ tGetBlock th
+      ts <- liftEither $ parse smpP TEBadBlock s
+      pure $ L.map (\(Large t) -> parse transmissionP TEBadBlock t) ts
 
 -- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (SignedTransmission cmd)
-tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= decodeParseValidate
+tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (NonEmpty (SignedTransmission cmd))
+tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM decodeParseValidate
   where
     decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
     decodeParseValidate = \case

src/Simplex/Messaging/Server.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
@@ -43,17 +44,14 @@ import Crypto.Random
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Either (fromRight)
+import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.List (intercalate)
+import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing)
-import Data.Set (Set)
-import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
-import Data.Time.Calendar.Month.Compat (pattern MonthDay)
-import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
@@ -78,6 +76,7 @@ import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
+import System.IO (hPutStrLn)
 import System.Mem.Weak (deRefWeak)
 import UnliftIO.Concurrent
 import UnliftIO.Directory (doesFileExist, renameFile)
@@ -144,7 +143,7 @@ smpServer started = do
         endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
         endPreviousSubscriptions (qId, c) = do
           void . forkIO . atomically $
-            writeTBQueue (sndQ c) (CorrId "", qId, END)
+            writeTBQueue (sndQ c) [(CorrId "", qId, END)]
           atomically $ TM.lookupDelete qId (clientSubs c)
 
     expireMessagesThread_ :: ServerConfig -> [m ()]
@@ -165,36 +164,30 @@ smpServer started = do
             >>= atomically . (`deleteExpiredMsgs` old)
 
     serverStatsThread_ :: ServerConfig -> [m ()]
-    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime} =
-      [logServerStats logStatsStartTime interval]
+    serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
+      [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
-    logServerStats :: Int -> Int -> m ()
-    logServerStats startAt logInterval = do
+    logServerStats :: Int -> Int -> FilePath -> m ()
+    logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      logInfo "fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues"
+      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues} <- asks serverStats
       let interval = 1000000 * logInterval
-      forever $ do
-        ts <- liftIO getCurrentTime
-        fromTime' <- atomically $ swapTVar fromTime ts
-        qCreated' <- atomically $ swapTVar qCreated 0
-        qSecured' <- atomically $ swapTVar qSecured 0
-        qDeleted' <- atomically $ swapTVar qDeleted 0
-        msgSent' <- atomically $ swapTVar msgSent 0
-        msgRecv' <- atomically $ swapTVar msgRecv 0
-        let day = utctDay ts
-            (_, wDay) = mondayStartWeek day
-            MonthDay _ mDay = day
-        (dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
-          atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
-        logInfo . T.pack $ intercalate "," [iso8601Show fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', show dayMsgQueues', weekMsgQueues', monthMsgQueues']
-        threadDelay interval
-      where
-        periodCount :: Int -> TVar (Set RecipientId) -> STM String
-        periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
-        periodCount _ _ = pure ""
+      withFile statsFilePath AppendMode $ \h -> liftIO $ do
+        hSetBuffering h LineBuffering
+        forever $ do
+          ts <- getCurrentTime
+          fromTime' <- atomically $ swapTVar fromTime ts
+          qCreated' <- atomically $ swapTVar qCreated 0
+          qSecured' <- atomically $ swapTVar qSecured 0
+          qDeleted' <- atomically $ swapTVar qDeleted 0
+          msgSent' <- atomically $ swapTVar msgSent 0
+          msgRecv' <- atomically $ swapTVar msgRecv 0
+          ps <- atomically $ periodStatCounts activeQueues ts
+          hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayCount ps, weekCount ps, monthCount ps]
+          threadDelay interval
 
     runClient :: Transport c => TProxy c -> c -> m ()
     runClient _ h = do
@@ -240,26 +233,36 @@ cancelSub sub =
     Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
     _ -> return ()
 
-receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
+receive :: forall c m. (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
 receive th Client {rcvQ, sndQ, activeAt} = forever $ do
-  (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
+  ts <- L.toList <$> tGet th
   atomically . writeTVar activeAt =<< liftIO getSystemTime
-  case cmdOrError of
-    Left e -> write sndQ (corrId, queueId, ERR e)
-    Right cmd -> do
-      verified <- verifyTransmission sig signed queueId cmd
-      if verified
-        then write rcvQ (corrId, queueId, cmd)
-        else write sndQ (corrId, queueId, ERR AUTH)
+  as <- partitionEithers <$> mapM cmdAction ts
+  write sndQ $ fst as
+  write rcvQ $ snd as
   where
-    write q t = atomically $ writeTBQueue q t
+    cmdAction :: SignedTransmission Cmd -> m (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
+    cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
+      case cmdOrError of
+        Left e -> pure $ Left (corrId, queueId, ERR e)
+        Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
+          where
+            verified = \case
+              VRVerified qr -> Right (qr, (corrId, queueId, cmd))
+              VRFailed -> Left (corrId, queueId, ERR AUTH)
+    write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
 send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
 send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
-  t <- atomically $ readTBQueue sndQ
-  -- TODO the line below can return Left, but we ignore it and do not disconnect the client
-  void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
+  ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
+  -- 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
+    tOrder :: Transmission BrokerMsg -> Int
+    tOrder (_, _, cmd) = case cmd of
+      MSG {} -> 0
+      _ -> 1
 
 disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
 disconnectTransport THandle {connection} c activeAt expCfg = do
@@ -270,23 +273,28 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
     ts <- readTVarIO $ activeAt c
     when (systemSeconds ts < old) $ closeConnection connection
 
+data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
+
 verifyTransmission ::
-  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
+  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m VerificationResult
 verifyTransmission sig_ signed queueId cmd = do
   case cmd of
-    Cmd SRecipient (NEW k _) -> pure $ verifyCmdSignature sig_ signed k
+    Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
     Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
-    Cmd SSender PING -> pure True
+    Cmd SSender PING -> pure $ VRVerified Nothing
     Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
   where
-    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m VerificationResult
     verifyCmd party f = do
       st <- asks queueStore
-      q <- atomically $ getQueue st party queueId
-      pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
+      q_ <- atomically (getQueue st party queueId)
+      pure $ case q_ of
+        Right q -> Just q `verified` f q
+        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
     verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
     verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
+    verified q cond = if cond then VRVerified q else VRFailed
 
 verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
 verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
@@ -317,16 +325,16 @@ client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server ->
 client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
-      >>= processCommand
+      >>= mapM processCommand
       >>= atomically . writeTBQueue sndQ
   where
-    processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
-    processCommand (corrId, queueId, cmd) = do
+    processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
+    processCommand (qr_, (corrId, queueId, cmd)) = do
       st <- asks queueStore
       case cmd of
         Cmd SSender command ->
           case command of
-            SEND flags msgBody -> sendMessage st flags msgBody
+            SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
             PING -> pure (corrId, "", PONG)
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
@@ -336,9 +344,9 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                 (asks $ allowNewQueues . config)
                 (createQueue st rKey dhKey)
                 (pure (corrId, queueId, ERR AUTH))
-            SUB -> subscribeQueue st queueId
-            GET -> getMessage st
-            ACK msgId -> acknowledgeMsg st msgId
+            SUB -> withQueue (`subscribeQueue` queueId)
+            GET -> withQueue getMessage
+            ACK msgId -> withQueue (`acknowledgeMsg` msgId)
             KEY sKey -> secureQueue_ st sKey
             NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
             NDEL -> deleteQueueNotifier_ st
@@ -368,14 +376,15 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             addQueueRetry n qik qRec = do
               ids@(rId, _) <- getIds
               -- create QueueRec record with these ids and keys
-              atomically (addQueue st $ qRec ids) >>= \case
+              let qr = qRec ids
+              atomically (addQueue st qr) >>= \case
                 Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
                 Left e -> pure $ ERR e
                 Right _ -> do
                   withLog (`logCreateById` rId)
                   stats <- asks serverStats
                   atomically $ modifyTVar (qCreated stats) (+ 1)
-                  subscribeQueue st rId $> IDS (qik ids)
+                  subscribeQueue qr rId $> IDS (qik ids)
 
             logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
             logCreateById s rId =
@@ -420,11 +429,15 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
 
         suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
         suspendQueue_ st = do
-          withLog (`logDeleteQueue` queueId)
-          okResp <$> atomically (suspendQueue st queueId)
+          withLog (`logSuspendQueue` queueId)
+          ms <- asks msgStore
+          quota <- asks $ msgQueueQuota . config
+          let queueLen _ = fmap fromIntegral . queueLength =<< getMsgQueue ms queueId quota
+          len <- atomically (suspendQueue st queueId >>= mapM queueLen)
+          pure (corrId, queueId, either ERR LEN len)
 
-        subscribeQueue :: QueueStore -> RecipientId -> m (Transmission BrokerMsg)
-        subscribeQueue st rId =
+        subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
+        subscribeQueue qr rId =
           atomically (TM.lookup rId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= deliver
@@ -446,10 +459,10 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             deliver sub = do
               q <- getStoreMsgQueue rId
               msg_ <- atomically $ tryPeekMsg q
-              deliverMessage st rId sub q msg_
+              deliverMessage qr rId sub q msg_
 
-        getMessage :: QueueStore -> m (Transmission BrokerMsg)
-        getMessage st =
+        getMessage :: QueueRec -> m (Transmission BrokerMsg)
+        getMessage qr =
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing ->
               atomically newSub >>= getMessage_
@@ -468,7 +481,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
               TM.insert queueId sub subscriptions
               pure s
             getMessage_ :: Sub -> m (Transmission BrokerMsg)
-            getMessage_ s = withRcvQueue st queueId $ \qr -> do
+            getMessage_ s = do
               q <- getStoreMsgQueue queueId
               atomically $
                 tryPeekMsg q >>= \case
@@ -477,11 +490,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                      in setDelivered s msg $> (corrId, queueId, MSG encMsg)
                   _ -> pure (corrId, queueId, OK)
 
-        withRcvQueue :: QueueStore -> RecipientId -> (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
-        withRcvQueue st rId action =
-          atomically (getQueue st SRecipient rId) >>= \case
-            Left e -> pure (corrId, rId, ERR e)
-            Right qr -> action qr
+        withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
+        withQueue action = maybe (pure $ err AUTH) action qr_
 
         subscribeNotifications :: m (Transmission BrokerMsg)
         subscribeNotifications = atomically $ do
@@ -490,8 +500,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             TM.insert queueId () ntfSubscriptions
           pure ok
 
-        acknowledgeMsg :: QueueStore -> MsgId -> m (Transmission BrokerMsg)
-        acknowledgeMsg st msgId = do
+        acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
+        acknowledgeMsg qr msgId = do
           atomically (TM.lookup queueId subscriptions) >>= \case
             Nothing -> pure $ err NO_MSG
             Just sub ->
@@ -506,7 +516,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                     _ -> do
                       (msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
                       when msgDeleted updateStats
-                      deliverMessage st queueId sub q msg_
+                      deliverMessage qr queueId sub q msg_
                 _ -> pure $ err NO_MSG
           where
             getDelivered :: TVar Sub -> STM (Maybe Sub)
@@ -520,84 +530,73 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
             updateStats = do
               stats <- asks serverStats
               atomically $ modifyTVar (msgRecv stats) (+ 1)
-              atomically $ updateActiveQueues stats queueId
+              atomically $ updatePeriodStats (activeQueues stats) queueId
 
-        updateActiveQueues :: ServerStats -> RecipientId -> STM ()
-        updateActiveQueues stats qId = do
-          updatePeriod dayMsgQueues
-          updatePeriod weekMsgQueues
-          updatePeriod monthMsgQueues
-          where
-            updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
-
-        sendMessage :: QueueStore -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
-        sendMessage st msgFlags msgBody
+        sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
+        sendMessage qr msgFlags msgBody
           | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
-          | otherwise = do
-            qr <- atomically $ getQueue st SSender queueId
-            either (return . err) storeMessage qr
+          | otherwise = case status qr of
+            QueueOff -> return $ err AUTH
+            QueueActive ->
+              mapM mkMessage (C.maxLenBS msgBody) >>= \case
+                Left _ -> pure $ err LARGE_MSG
+                Right msg -> do
+                  ms <- asks msgStore
+                  ServerConfig {messageExpiration, msgQueueQuota} <- asks config
+                  old <- liftIO $ mapM expireBeforeEpoch messageExpiration
+                  ntfNonceDrg <- asks idsDrg
+                  resp@(_, _, sent) <- atomically $ do
+                    q <- getMsgQueue ms (recipientId qr) msgQueueQuota
+                    mapM_ (deleteExpiredMsgs q) old
+                    ifM (isFull q) (pure $ err QUOTA) $ do
+                      when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
+                      writeMsg q msg
+                      pure ok
+                  when (sent == OK) $ do
+                    stats <- asks serverStats
+                    atomically $ modifyTVar (msgSent stats) (+ 1)
+                    atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
+                  pure resp
           where
-            storeMessage :: QueueRec -> m (Transmission BrokerMsg)
-            storeMessage qr = case status qr of
-              QueueOff -> return $ err AUTH
-              QueueActive ->
-                mapM mkMessage (C.maxLenBS msgBody) >>= \case
-                  Left _ -> pure $ err LARGE_MSG
-                  Right msg -> do
-                    ms <- asks msgStore
-                    ServerConfig {messageExpiration, msgQueueQuota} <- asks config
-                    old <- liftIO $ mapM expireBeforeEpoch messageExpiration
-                    ntfNonceDrg <- asks idsDrg
-                    resp@(_, _, sent) <- atomically $ do
-                      q <- getMsgQueue ms (recipientId qr) msgQueueQuota
-                      mapM_ (deleteExpiredMsgs q) old
-                      ifM (isFull q) (pure $ err QUOTA) $ do
-                        when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
-                        writeMsg q msg
-                        pure ok
-                    when (sent == OK) $ do
-                      stats <- asks serverStats
-                      atomically $ modifyTVar (msgSent stats) (+ 1)
-                      atomically $ updateActiveQueues stats $ recipientId qr
-                    pure resp
-              where
-                mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
-                mkMessage body = do
-                  msgId <- randomId =<< asks (msgIdBytes . config)
-                  msgTs <- liftIO getSystemTime
-                  pure $ Message msgId msgTs msgFlags body
+            mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
+            mkMessage body = do
+              msgId <- randomId =<< asks (msgIdBytes . config)
+              msgTs <- liftIO getSystemTime
+              pure $ Message msgId msgTs msgFlags body
 
-                trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
-                trySendNotification msg ntfNonceDrg =
-                  forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
-                    mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
+            trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
+            trySendNotification msg ntfNonceDrg =
+              forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
+                mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
 
-                writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
-                writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
-                  unlessM (isFullTBQueue sndQ) $ do
-                    (nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
-                    writeTBQueue q (CorrId "", nId, NMSG nmsgNonce encNMsgMeta)
+            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
+            writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
+              unlessM (isFullTBQueue sndQ) $ do
+                (nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
+                writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
 
-                mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
-                mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
-                  cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
-                  let msgMeta = NMsgMeta {msgId, msgTs}
-                      encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
-                  pure . (cbNonce,) $ fromRight "" encNMsgMeta
+            mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
+            mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
+              cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
+              let msgMeta = NMsgMeta {msgId, msgTs}
+                  encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
+              pure . (cbNonce,) $ fromRight "" encNMsgMeta
 
-        deliverMessage :: QueueStore -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
-        deliverMessage st rId sub q msg_ = withRcvQueue st rId $ \qr -> do
+        deliverMessage :: QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
+        deliverMessage qr rId sub q msg_ = do
           readTVarIO sub >>= \case
             s@Sub {subThread = NoSub} ->
               case msg_ of
                 Just msg ->
                   let encMsg = encryptMsg qr msg
                    in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
-                _ -> forkSub qr $> ok
+                _
+                  | status qr == QueueActive -> forkSub $> ok
+                  | otherwise -> pure (corrId, rId, LEN 0)
             _ -> pure ok
           where
-            forkSub :: QueueRec -> m ()
-            forkSub qr = do
+            forkSub :: m ()
+            forkSub = do
               atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
               t <- mkWeakThreadId =<< forkIO subscriber
               atomically . modifyTVar sub $ \case
@@ -607,20 +606,20 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
                 subscriber = atomically $ do
                   msg <- peekMsg q
                   let encMsg = encryptMsg qr msg
-                  writeTBQueue sndQ (CorrId "", rId, MSG encMsg)
+                  writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
                   s <- readTVar sub
                   void $ setDelivered s msg
                   writeTVar sub s {subThread = NoSub}
 
         encryptMsg :: QueueRec -> Message -> RcvMessage
         encryptMsg qr Message {msgId, msgTs, msgFlags, msgBody}
-          | thVersion == 1 || thVersion == 2 = encrypt msgBody
-          | otherwise = encrypt $ encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody}
+          | thVersion == 1 || thVersion == 2 = encrypt msgTs msgFlags msgBody
+          | otherwise = encrypt (MkSystemTime 0 0) noMsgFlags $ encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody}
           where
-            encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
-            encrypt body =
+            encrypt :: KnownNat i => SystemTime -> MsgFlags -> C.MaxLenBS i -> RcvMessage
+            encrypt msgTs' msgFlags' body =
               let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId) body
-               in RcvMessage msgId msgTs msgFlags encBody
+               in RcvMessage msgId msgTs' msgFlags' encBody
 
         setDelivered :: Sub -> Message -> STM Bool
         setDelivered s Message {msgId} = tryPutTMVar (delivered s) msgId
@@ -714,7 +713,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
 
 saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
 saveServerStats =
-  asks (serverStatsFile . config)
+  asks (serverStatsBackupFile . config)
     >>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
@@ -723,14 +722,16 @@ saveServerStats =
       logInfo "server stats saved"
 
 restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
-restoreServerStats = asks (serverStatsFile . config) >>= mapM_ restoreStats
+restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
   where
     restoreStats f = whenM (doesFileExist f) $ do
       logInfo $ "restoring server stats from file " <> T.pack f
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          atomically $ setServerStatsData s d
+          atomically $ setServerStats s d
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
-        Left e -> logInfo $ "error restoring server stats: " <> T.pack e
+        Left e -> do
+          logInfo $ "error restoring server stats: " <> T.pack e
+          liftIO exitFailure

src/Simplex/Messaging/Server/CLI.hs

@@ -23,7 +23,8 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (loadFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
+import Simplex.Messaging.Util (whenM)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
@@ -147,7 +148,7 @@ cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
 
 initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
 initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
-  cleanup cliCfg
+  clearDirs cliCfg
   createDirectoryIfMissing True cfgDir
   createDirectoryIfMissing True logDir
   createX509
@@ -276,7 +277,14 @@ cleanup ServerCLIConfig {cfgDir, logDir} = do
   deleteDirIfExists cfgDir
   deleteDirIfExists logDir
   where
-    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
+    deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
+
+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)
 
 printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
 printServiceInfo ServerCLIConfig {serverVersion} fpStr = do

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

@@ -9,6 +9,7 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Time.Clock (getCurrentTime)
@@ -55,8 +56,10 @@ data ServerConfig = ServerConfig
     -- | time of the day when the stats are logged first, to log at consistent times,
     -- irrespective of when the server is started (seconds from 00:00 UTC)
     logStatsStartTime :: Int,
+    -- | file to log stats
+    serverStatsLogFile :: FilePath,
     -- | file to save and restore stats
-    serverStatsFile :: Maybe FilePath,
+    serverStatsBackupFile :: Maybe FilePath,
     -- | CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -101,8 +104,8 @@ data Server = Server
 data Client = Client
   { subscriptions :: TMap RecipientId (TVar Sub),
     ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (Transmission Cmd),
-    sndQ :: TBQueue (Transmission BrokerMsg),
+    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
+    sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     thVersion :: Version,
     sessionId :: ByteString,
     connected :: TVar Bool,

src/Simplex/Messaging/Server/MsgStore.hs

@@ -25,6 +25,7 @@ class MonadMsgStore s q m | s -> q where
 
 class MonadMsgQueue q m where
   isFull :: q -> m Bool
+  queueLength :: q -> m Natural
   writeMsg :: q -> Message -> m () -- non blocking
   tryPeekMsg :: q -> m (Maybe Message) -- non blocking
   peekMsg :: q -> m Message -- blocking

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

@@ -9,7 +9,7 @@
 
 module Simplex.Messaging.Server.MsgStore.STM where
 
-import Control.Concurrent.STM.TBQueue (flushTBQueue)
+import Control.Concurrent.STM.TBQueue (flushTBQueue, lengthTBQueue)
 import Control.Monad (when)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
@@ -48,6 +48,9 @@ instance MonadMsgQueue MsgQueue STM where
   isFull :: MsgQueue -> STM Bool
   isFull = isFullTBQueue . msgQueue
 
+  queueLength :: MsgQueue -> STM Natural
+  queueLength = lengthTBQueue . msgQueue
+
   writeMsg :: MsgQueue -> Message -> STM ()
   writeMsg = writeTBQueue . msgQueue
 

src/Simplex/Messaging/Server/QueueStore.hs

@@ -15,7 +15,7 @@ data QueueRec = QueueRec
     senderId :: SenderId,
     senderKey :: Maybe SndPublicVerifyKey,
     notifier :: Maybe NtfCreds,
-    status :: QueueStatus
+    status :: ServerQueueStatus
   }
   deriving (Eq, Show)
 
@@ -32,7 +32,7 @@ instance StrEncoding NtfCreds where
     (notifierId, notifierKey, rcvNtfDhSecret) <- strP
     pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
 
-data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
+data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)
 
 class MonadQueueStore s m where
   addQueue :: s -> QueueRec -> m (Either ErrorType ())

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

@@ -58,8 +58,10 @@ instance MonadQueueStore QueueStore STM where
   secureQueue QueueStore {queues} rId sKey =
     withQueue rId queues $ \qVar ->
       readTVar qVar >>= \q -> case senderKey q of
-        Just _ -> pure Nothing
-        _ -> writeTVar qVar q {senderKey = Just sKey} $> Just q
+        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

src/Simplex/Messaging/Server/Stats.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Server.Stats where
 
@@ -8,7 +10,9 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Time.Clock (UTCTime)
+import Data.Time.Calendar.Month.Compat (pattern MonthDay)
+import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
+import Data.Time.Clock (UTCTime (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RecipientId)
 import UnliftIO.STM
@@ -20,9 +24,7 @@ data ServerStats = ServerStats
     qDeleted :: TVar Int,
     msgSent :: TVar Int,
     msgRecv :: TVar Int,
-    dayMsgQueues :: TVar (Set RecipientId),
-    weekMsgQueues :: TVar (Set RecipientId),
-    monthMsgQueues :: TVar (Set RecipientId)
+    activeQueues :: PeriodStats RecipientId
   }
 
 data ServerStatsData = ServerStatsData
@@ -32,9 +34,7 @@ data ServerStatsData = ServerStatsData
     _qDeleted :: Int,
     _msgSent :: Int,
     _msgRecv :: Int,
-    _dayMsgQueues :: Set RecipientId,
-    _weekMsgQueues :: Set RecipientId,
-    _monthMsgQueues :: Set RecipientId
+    _activeQueues :: PeriodStatsData RecipientId
   }
 
 newServerStats :: UTCTime -> STM ServerStats
@@ -45,10 +45,8 @@ newServerStats ts = do
   qDeleted <- newTVar 0
   msgSent <- newTVar 0
   msgRecv <- newTVar 0
-  dayMsgQueues <- newTVar S.empty
-  weekMsgQueues <- newTVar S.empty
-  monthMsgQueues <- newTVar S.empty
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues}
+  activeQueues <- newPeriodStats
+  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
@@ -58,25 +56,21 @@ getServerStatsData s = do
   _qDeleted <- readTVar $ qDeleted s
   _msgSent <- readTVar $ msgSent s
   _msgRecv <- readTVar $ msgRecv s
-  _dayMsgQueues <- readTVar $ dayMsgQueues s
-  _weekMsgQueues <- readTVar $ weekMsgQueues s
-  _monthMsgQueues <- readTVar $ monthMsgQueues s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
+  _activeQueues <- getPeriodStatsData $ activeQueues s
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
 
-setServerStatsData :: ServerStats -> ServerStatsData -> STM ()
-setServerStatsData s d = do
+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 (dayMsgQueues s) (_dayMsgQueues d)
-  writeTVar (weekMsgQueues s) (_weekMsgQueues d)
-  writeTVar (monthMsgQueues s) (_monthMsgQueues d)
+  setPeriodStats (activeQueues s) (_activeQueues d)
 
 instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues} =
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "qCreated=" <> strEncode _qCreated,
@@ -84,9 +78,8 @@ instance StrEncoding ServerStatsData where
         "qDeleted=" <> strEncode _qDeleted,
         "msgSent=" <> strEncode _msgSent,
         "msgRecv=" <> strEncode _msgRecv,
-        "dayMsgQueues=" <> strEncode _dayMsgQueues,
-        "weekMsgQueues=" <> strEncode _weekMsgQueues,
-        "monthMsgQueues=" <> strEncode _monthMsgQueues
+        "activeQueues:",
+        strEncode _activeQueues
       ]
   strP = do
     _fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -95,7 +88,81 @@ instance StrEncoding ServerStatsData where
     _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
     _msgSent <- "msgSent=" *> strP <* A.endOfLine
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    _dayMsgQueues <- "dayMsgQueues=" *> strP <* A.endOfLine
-    _weekMsgQueues <- "weekMsgQueues=" *> strP <* A.endOfLine
-    _monthMsgQueues <- "monthMsgQueues=" *> strP <* optional A.endOfLine
-    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
+    r <- optional ("activeQueues:" <* A.endOfLine)
+    _activeQueues <- case r of
+      Just _ -> strP <* optional A.endOfLine
+      _ -> do
+        _day <- "dayMsgQueues=" *> strP <* A.endOfLine
+        _week <- "weekMsgQueues=" *> strP <* A.endOfLine
+        _month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
+        pure PeriodStatsData {_day, _week, _month}
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
+
+data PeriodStats a = PeriodStats
+  { day :: TVar (Set a),
+    week :: TVar (Set a),
+    month :: TVar (Set a)
+  }
+
+newPeriodStats :: STM (PeriodStats a)
+newPeriodStats = do
+  day <- newTVar S.empty
+  week <- newTVar S.empty
+  month <- newTVar S.empty
+  pure PeriodStats {day, week, month}
+
+data PeriodStatsData a = PeriodStatsData
+  { _day :: Set a,
+    _week :: Set a,
+    _month :: Set a
+  }
+
+getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
+getPeriodStatsData s = do
+  _day <- readTVar $ day s
+  _week <- readTVar $ week s
+  _month <- readTVar $ month s
+  pure PeriodStatsData {_day, _week, _month}
+
+setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
+setPeriodStats s d = do
+  writeTVar (day s) (_day d)
+  writeTVar (week s) (_week d)
+  writeTVar (month s) (_month d)
+
+instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
+  strEncode PeriodStatsData {_day, _week, _month} =
+    "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
+  strP = do
+    _day <- "day=" *> strP <* A.endOfLine
+    _week <- "week=" *> strP <* A.endOfLine
+    _month <- "month=" *> strP
+    pure PeriodStatsData {_day, _week, _month}
+
+data PeriodStatCounts = PeriodStatCounts
+  { dayCount :: String,
+    weekCount :: String,
+    monthCount :: String
+  }
+
+periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
+periodStatCounts ps ts = do
+  let d = utctDay ts
+      (_, wDay) = mondayStartWeek d
+      MonthDay _ mDay = d
+  dayCount <- periodCount 1 $ day ps
+  weekCount <- periodCount wDay $ week ps
+  monthCount <- periodCount mDay $ month ps
+  pure PeriodStatCounts {dayCount, weekCount, monthCount}
+  where
+    periodCount :: Int -> TVar (Set a) -> STM String
+    periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
+    periodCount _ _ = pure ""
+
+updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
+updatePeriodStats stats pId = do
+  updatePeriod day
+  updatePeriod week
+  updatePeriod month
+  where
+    updatePeriod pSel = modifyTVar (pSel stats) (S.insert pId)

src/Simplex/Messaging/Server/StoreLog.hs

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

src/Simplex/Messaging/TMap.hs

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

src/Simplex/Messaging/TMap2.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Messaging.TMap2
+  ( TMap2,
+    empty,
+    clear,
+    Simplex.Messaging.TMap2.lookup,
+    lookup1,
+    member,
+    insert,
+    insert1,
+    delete,
+    lookupDelete1,
+  )
+where
+
+import Control.Concurrent.STM
+import Control.Monad (forM_, (>=>))
+import qualified Data.Map.Strict as M
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (whenM, ($>>=))
+
+-- | this type is designed for k2 being unique in the whole data, and k1 grouping multiple values with k2 keys.
+-- It allows direct access via k1 to a group of k2 values and via k2 to one value
+data TMap2 k1 k2 a = TMap2
+  { _m1 :: TMap k1 (TMap k2 a),
+    _m2 :: TMap k2 k1
+  }
+
+empty :: STM (TMap2 k1 k2 a)
+empty = TMap2 <$> TM.empty <*> TM.empty
+
+clear :: TMap2 k1 k2 a -> STM ()
+clear TMap2 {_m1, _m2} = TM.clear _m1 >> TM.clear _m2
+
+lookup :: (Ord k1, Ord k2) => k2 -> TMap2 k1 k2 a -> STM (Maybe a)
+lookup k2 TMap2 {_m1, _m2} = do
+  TM.lookup k2 _m2 $>>= (`TM.lookup` _m1) $>>= TM.lookup k2
+
+lookup1 :: Ord k1 => k1 -> TMap2 k1 k2 a -> STM (Maybe (TMap k2 a))
+lookup1 k1 TMap2 {_m1} = TM.lookup k1 _m1
+{-# INLINE lookup1 #-}
+
+member :: Ord k2 => k2 -> TMap2 k1 k2 a -> STM Bool
+member k2 TMap2 {_m2} = TM.member k2 _m2
+{-# INLINE member #-}
+
+insert :: (Ord k1, Ord k2) => k1 -> k2 -> a -> TMap2 k1 k2 a -> STM ()
+insert k1 k2 v TMap2 {_m1, _m2} =
+  TM.lookup k2 _m2 >>= \case
+    Just k1'
+      | k1 == k1' -> _insert1
+      | otherwise -> _delete1 k1' k2 _m1 >> _insert2
+    _ -> _insert2
+  where
+    _insert1 =
+      TM.lookup k1 _m1 >>= \case
+        Just m -> TM.insert k2 v m
+        _ -> TM.singleton k2 v >>= \m -> TM.insert k1 m _m1
+    _insert2 = TM.insert k2 k1 _m2 >> _insert1
+
+insert1 :: (Ord k1, Ord k2) => k1 -> TMap k2 a -> TMap2 k1 k2 a -> STM ()
+insert1 k1 m' TMap2 {_m1, _m2} =
+  TM.lookup k1 _m1 >>= \case
+    Just m -> readTVar m' >>= (`TM.union` m)
+    _ -> TM.insert k1 m' _m1
+
+delete :: (Ord k1, Ord k2) => k2 -> TMap2 k1 k2 a -> STM ()
+delete k2 TMap2 {_m1, _m2} = TM.lookupDelete k2 _m2 >>= mapM_ (\k1 -> _delete1 k1 k2 _m1)
+
+_delete1 :: (Ord k1, Ord k2) => k1 -> k2 -> TMap k1 (TMap k2 a) -> STM ()
+_delete1 k1 k2 m1 =
+  TM.lookup k1 m1
+    >>= mapM_ (\m -> TM.delete k2 m >> whenM (TM.null m) (TM.delete k1 m1))
+
+lookupDelete1 :: (Ord k1, Ord k2) => k1 -> TMap2 k1 k2 a -> STM (Maybe (TMap k2 a))
+lookupDelete1 k1 TMap2 {_m1, _m2} = do
+  m_ <- TM.lookupDelete k1 _m1
+  forM_ m_ $ readTVar >=> modifyTVar' _m2 . flip M.withoutKeys . M.keysSet
+  pure m_

src/Simplex/Messaging/Transport.hs

@@ -96,10 +96,10 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 3
+supportedSMPServerVRange = mkVersionRange 1 4
 
 simplexMQVersion :: String
-simplexMQVersion = "3.0.0"
+simplexMQVersion = "3.2.0"
 
 -- * Transport connection class
 
@@ -258,7 +258,10 @@ data THandle c = THandle
     sessionId :: SessionId,
     blockSize :: Int,
     -- | agreed server protocol version
-    thVersion :: Version
+    thVersion :: Version,
+    -- | send multiple transmissions in a single block
+    -- based on protocol and protocol version
+    batch :: Bool
   }
 
 -- | TLS-unique channel binding
@@ -364,7 +367,7 @@ smpServerHandshake c kh smpVRange = do
       | keyHash /= kh ->
         throwE $ TEHandshake IDENTITY
       | smpVersion `isCompatible` smpVRange -> do
-        pure (th :: THandle c) {thVersion = smpVersion}
+        pure $ smpThHandle th smpVersion
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | Client SMP transport handshake.
@@ -379,9 +382,12 @@ smpClientHandshake c keyHash smpVRange = do
     else case smpVersionRange `compatibleVersion` smpVRange of
       Just (Compatible smpVersion) -> do
         sendHandshake th $ ClientHandshake {smpVersion, keyHash}
-        pure (th :: THandle c) {thVersion = smpVersion}
+        pure $ smpThHandle th smpVersion
       Nothing -> throwE $ TEHandshake VERSION
 
+smpThHandle :: forall c. THandle c -> Version -> THandle c
+smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
+
 sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
 sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
@@ -389,4 +395,4 @@ getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportErr
 getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
 
 smpTHandle :: Transport c => c -> THandle c
-smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0}
+smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}

src/Simplex/Messaging/Transport/Client.hs

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

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

@@ -19,7 +19,7 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.Client (runTLSTransportClient)
+import Simplex.Messaging.Transport.Client (TransportHost (..), runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
 import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
 import UnliftIO.STM
@@ -122,7 +122,7 @@ sendRequest HTTP2Client {reqQ, config} req = do
 
 runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
 runHTTP2Client tlsParams caStore host port keepAliveOpts client =
-  runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \c ->
+  runTLSTransportClient tlsParams caStore Nothing (THDomainName host) port Nothing keepAliveOpts $ \c ->
     withTlsConfig c 16384 (`run` client)
   where
     run = H.run $ ClientConfig "https" (B.pack host) 20

src/Simplex/Messaging/Transport/KeepAlive.hs

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

src/Simplex/Messaging/Util.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 

src/Simplex/Messaging/Version.hs

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

stack.yaml

@@ -38,8 +38,8 @@ extra-deps:
   - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
   - network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
   - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
-  - tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
-  # below dependancies are to update Aeson to 2.0.3
+  - tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987
+  # below dependencies are to update Aeson to 2.0.3
   - OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
   - attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
   - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005

tests/AgentTests.hs

@@ -78,9 +78,17 @@ agentTests (ATransport t) = do
     it "should deliver messages if one of connections has quota exceeded" $
       smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
 
+tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
+tGetAgent h = do
+  t@(_, _, cmd) <- tGet SAgent h
+  case cmd of
+    Right CONNECT {} -> tGetAgent h
+    Right DISCONNECT {} -> tGetAgent h
+    _ -> pure t
+
 -- | receive message to handle `h`
 (<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
-(<#:) = tGet SAgent
+(<#:) = tGetAgent
 
 -- | send transmission `t` to handle `h` and get response
 (#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
@@ -114,7 +122,7 @@ h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
 h #:# err = tryGet `shouldReturn` ()
   where
     tryGet =
-      10000 `timeout` tGet SAgent h >>= \case
+      10000 `timeout` tGetAgent h >>= \case
         Just _ -> error err
         _ -> return ()
 
@@ -123,10 +131,10 @@ pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
 
 testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnection _ alice bob = do
-  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")
+  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
   alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   bob <# ("", "alice", INFO "alice's connInfo")
   bob <# ("", "alice", CON)
@@ -156,10 +164,10 @@ testDuplexConnection _ alice bob = do
 
 testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testDuplexConnRandomIds _ alice bob = do
-  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")
+  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV")
   let cReq' = strEncode cReq
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
-  ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo")
+  ("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
   bobConn' `shouldBe` bobConn
   alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
   bob <# ("", aliceConn, INFO "alice's connInfo")
@@ -189,13 +197,13 @@ testDuplexConnRandomIds _ alice bob = do
 
 testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()
 testContactConnection _ alice bob tom = do
-  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")
+  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON")
   let cReq' = strEncode cReq
 
-  bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
   alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-  ("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
+  ("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
   bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
   alice <# ("", "bob", INFO "bob's connInfo 2")
   alice <# ("", "bob", CON)
@@ -205,10 +213,10 @@ testContactConnection _ alice bob tom = do
   bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
   bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
 
-  tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
+  tom #: ("21", "alice", "JOIN T " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
+  ("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:)
   alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
-  ("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)
+  ("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:)
   tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
   alice <# ("", "tom", INFO "tom's connInfo 2")
   alice <# ("", "tom", CON)
@@ -220,15 +228,15 @@ testContactConnection _ alice bob tom = do
 
 testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
 testContactConnRandomIds _ alice bob = do
-  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")
+  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON")
   let cReq' = strEncode cReq
 
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
-  ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo")
+  ("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
   aliceContact' `shouldBe` aliceContact
 
   ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
-  ("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
+  ("", aliceConn', Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
   aliceConn' `shouldBe` aliceConn
 
   bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
@@ -243,10 +251,10 @@ testContactConnRandomIds _ alice bob = do
 
 testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
 testRejectContactRequest _ alice bob = do
-  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")
+  ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
-  ("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
+  ("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:)
   -- RJCT must use correct contact connection
   alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
   alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
@@ -274,7 +282,7 @@ testSubscription _ alice1 alice2 bob = do
 
 testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
 testSubscrNotification t (server, _) client = do
-  client #: ("1", "conn1", "NEW INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
+  client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
   client <# ("", "", DOWN testSMPServer ["conn1"])
@@ -323,7 +331,7 @@ testServerConnectionAfterError t _ = do
   withAgent1 $ \bob -> do
     withAgent2 $ \alice -> do
       bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
-      alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
+      alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER 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
@@ -384,10 +392,10 @@ testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
 testConcurrentMsgDelivery _ alice bob = do
   connect (alice, "alice") (bob, "bob")
 
-  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW INV")
+  ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
-  ("", "bob2", Right (CONF _confId "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice2", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
+  ("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:)
   -- below commands would be needed to accept bob's connection, but alice does not
   -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   -- bob <# ("", "alice", INFO "alice's connInfo")
@@ -423,10 +431,10 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
 
 connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
 connect (h1, name1) (h2, name2) = do
-  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
+  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV")
   let cReq' = strEncode cReq
-  h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
-  ("", _, Right (CONF connId "info2")) <- (h1 <#:)
+  h2 #: ("c2", name1, "JOIN T " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
+  ("", _, Right (CONF connId _ "info2")) <- (h1 <#:)
   h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
   h2 <# ("", name1, INFO "info1")
   h2 <# ("", name1, CON)
@@ -444,10 +452,10 @@ sendMessage (h1, name1) (h2, name2) msg = do
 
 -- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
 -- connect' h1 h2 = do
---   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")
+--   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV")
 --   let cReq' = strEncode cReq
---   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
---   ("", _, Right (REQ connId "info2")) <- (h1 <#:)
+--   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " 5\ninfo2")
+--   ("", _, Right (REQ connId _ "info2")) <- (h1 <#:)
 --   h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
 --   h2 <# ("", conn1, INFO "info1")
 --   h2 <# ("", conn1, CON)
@@ -463,17 +471,17 @@ syntaxTests t = do
   describe "NEW" $ do
     describe "valid" $ do
       -- TODO: add tests with defined connection id
-      it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
+      it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
     describe "invalid" $ do
       -- TODO: add tests with defined connection id
-      it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
+      it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX")
 
   describe "JOIN" $ do
     describe "valid" $ do
       it "using same server as in invitation" $
         ( "311",
           "a",
-          "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
+          "JOIN T https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
             <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
             <> "%40localhost%3A5001%2F3456-w%3D%3D%23"
             <> urlEncode True sampleDhKey

tests/AgentTests/ConnectionRequestTests.hs

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

tests/AgentTests/FunctionalAPITests.hs

@@ -17,12 +17,16 @@ module AgentTests.FunctionalAPITests
   )
 where
 
-import Control.Concurrent (threadDelay)
+import Control.Concurrent (killThread, threadDelay)
+import Control.Monad
 import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.IO.Unlift
+import Data.Int (Int64)
+import qualified Data.Map as M
+import qualified Data.Set as S
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import SMPAgentClient
-import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
+import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
@@ -43,7 +47,12 @@ a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
 a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
 
 get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
-get c = atomically (readTBQueue $ subQ c)
+get c = do
+  t@(_, _, cmd) <- atomically (readTBQueue $ subQ c)
+  case cmd of
+    CONNECT {} -> get c
+    DISCONNECT {} -> get c
+    _ -> pure t
 
 pattern Msg :: MsgBody -> ACommand 'Agent
 pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
@@ -52,7 +61,7 @@ smpCfgV1 :: ProtocolClientConfig
 smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = mkVersionRange 1 1}
 
 agentCfgV1 :: AgentConfig
-agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
+agentCfgV1 = agentCfg {smpAgentVRange = mkVersionRange 1 1, smpClientVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
 
 functionalAPITests :: ATransport -> Spec
 functionalAPITests t = do
@@ -102,6 +111,17 @@ functionalAPITests t = do
       testSuspendingAgentCompleteSending t
     it "should suspend agent on timeout, even if pending messages not sent" $
       testSuspendingAgentTimeout t
+  describe "Batching SMP commands" $ do
+    it "should subscribe to multiple subscriptions with batching" $
+      testBatchedSubscriptions t
+  describe "Switching receive queues" $
+    xit "should switch to a new queue" $
+      testSwitchRcvQueue t
+  describe "Async agent commands" $ do
+    it "should connect using async agent commands" $
+      withSmpServer t testAsyncCommands
+    it "should restore and complete async commands on restart" $
+      testAsyncCommandsRestore t
 
 testAgentClient :: IO ()
 testAgentClient = do
@@ -154,9 +174,9 @@ testAgentClientContactV2toV1 = do
 runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientTest alice bob baseId = do
   Right () <- runExceptT $ do
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -177,8 +197,8 @@ runAgentClientTest alice bob baseId = do
     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 3
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
+    _ <- suspendConnection alice bobId
     ackMessage alice bobId $ baseId + 4
-    suspendConnection alice bobId
     5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
@@ -190,11 +210,11 @@ runAgentClientTest alice bob baseId = do
 runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientContactTest alice bob baseId = do
   Right () <- runExceptT $ do
-    (_, qInfo) <- createConnection alice SCMContact
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, REQ invId "bob's connInfo") <- get alice
-    bobId <- acceptContact alice invId "alice's connInfo"
-    ("", _, CONF confId "alice's connInfo") <- get bob
+    (_, qInfo) <- createConnection alice True SCMContact
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, REQ invId _ "bob's connInfo") <- get alice
+    bobId <- acceptContact alice True invId "alice's connInfo"
+    ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
     get alice ##> ("", bobId, INFO "bob's connInfo")
     get alice ##> ("", bobId, CON)
@@ -216,7 +236,7 @@ runAgentClientContactTest alice bob baseId = do
     ackMessage alice bobId $ baseId + 3
     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 4
-    suspendConnection alice bobId
+    _ <- suspendConnection alice bobId
     5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
     get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
     deleteConnection alice bobId
@@ -238,12 +258,12 @@ testAsyncInitiatingOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    (bobId, cReq) <- createConnection alice SCMInvitation
+    (bobId, cReq) <- createConnection alice True SCMInvitation
     disconnectAgentClient alice
-    aliceId <- joinConnection bob cReq "bob's connInfo"
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
-    ("", _, CONF confId "bob's connInfo") <- get alice'
+    ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
     get alice' ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -256,10 +276,10 @@ testAsyncJoiningOfflineBeforeActivation = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
+    (bobId, qInfo) <- createConnection alice True SCMInvitation
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
     disconnectAgentClient bob
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
     subscribeConnection bob' aliceId
@@ -274,13 +294,13 @@ testAsyncBothOffline = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
-    (bobId, cReq) <- createConnection alice SCMInvitation
+    (bobId, cReq) <- createConnection alice True SCMInvitation
     disconnectAgentClient alice
-    aliceId <- joinConnection bob cReq "bob's connInfo"
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
     disconnectAgentClient bob
     alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
     subscribeConnection alice' bobId
-    ("", _, CONF confId "bob's connInfo") <- get alice'
+    ("", _, CONF confId _ "bob's connInfo") <- get alice'
     allowConnection alice' bobId confId "alice's connInfo"
     bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
     subscribeConnection bob' aliceId
@@ -296,9 +316,9 @@ testAsyncServerOffline t = do
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   -- create connection and shutdown the server
   Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
-    runExceptT $ createConnection alice SCMInvitation
+    runExceptT $ createConnection alice True SCMInvitation
   -- connection fails
-  Left (BROKER NETWORK) <- runExceptT $ joinConnection bob cReq "bob's connInfo"
+  Left (BROKER NETWORK) <- runExceptT $ joinConnection bob True cReq "bob's connInfo"
   ("", "", DOWN srv conns) <- get alice
   srv `shouldBe` testSMPServer
   conns `shouldBe` [bobId]
@@ -308,8 +328,8 @@ testAsyncServerOffline t = do
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
-    aliceId <- joinConnection bob cReq "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -323,9 +343,9 @@ testAsyncHelloTimeout = do
   alice <- getSMPAgentClient agentCfgV1 initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
   Right () <- runExceptT $ do
-    (_, cReq) <- createConnection alice SCMInvitation
+    (_, cReq) <- createConnection alice True SCMInvitation
     disconnectAgentClient alice
-    aliceId <- joinConnection bob cReq "bob's connInfo"
+    aliceId <- joinConnection bob True cReq "bob's connInfo"
     get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
   pure ()
 
@@ -380,9 +400,9 @@ testDuplicateMessage t = do
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnection alice bob = do
-  (bobId, qInfo) <- createConnection alice SCMInvitation
-  aliceId <- joinConnection bob qInfo "bob's connInfo"
-  ("", _, CONF confId "bob's connInfo") <- get alice
+  (bobId, qInfo) <- createConnection alice True SCMInvitation
+  aliceId <- joinConnection bob True qInfo "bob's connInfo"
+  ("", _, CONF confId _ "bob's connInfo") <- get alice
   allowConnection alice bobId confId "alice's connInfo"
   get alice ##> ("", bobId, CON)
   get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -395,7 +415,7 @@ testInactiveClientDisconnected t = do
   withSmpServerConfigOn t cfg' testPort $ \_ -> do
     alice <- getSMPAgentClient agentCfg initAgentServers
     Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice SCMInvitation
+      (connId, _cReq) <- createConnection alice True SCMInvitation
       get alice ##> ("", "", DOWN testSMPServer [connId])
     pure ()
 
@@ -406,7 +426,7 @@ testActiveClientNotDisconnected t = do
     alice <- getSMPAgentClient agentCfg initAgentServers
     ts <- getSystemTime
     Right () <- runExceptT $ do
-      (connId, _cReq) <- createConnection alice SCMInvitation
+      (connId, _cReq) <- createConnection alice True SCMInvitation
       keepSubscribing alice connId ts
     pure ()
   where
@@ -503,13 +523,129 @@ testSuspendingAgentTimeout t = do
 
   pure ()
 
+testBatchedSubscriptions :: ATransport -> IO ()
+testBatchedSubscriptions t = do
+  a <- getSMPAgentClient agentCfg initAgentServers2
+  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers2
+  Right 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
+    liftIO $ threadDelay 1000000
+    pure conns
+  ("", "", DOWN {}) <- get a
+  ("", "", DOWN {}) <- get a
+  ("", "", DOWN {}) <- get b
+  ("", "", DOWN {}) <- get b
+  Right () <- 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 ()
+  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 (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
+        M.keys r `shouldMatchList` cs
+    runServers :: ExceptT AgentErrorType IO a -> IO (Either AgentErrorType 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
+        killThread t1
+        pure res
+
+testSwitchRcvQueue :: ATransport -> IO ()
+testSwitchRcvQueue t = do
+  a <- getSMPAgentClient agentCfg initAgentServers2
+  b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers2
+  Right () <- withSmpServer t . withSmpServerOn t testPort2 . runExceptT $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetings a bId b aId
+    switchConnection a bId
+    r1 <- get b
+    liftIO $ print r1
+    -- r2 <- get b
+    -- liftIO $ print r2
+    r3 <- get a
+    liftIO $ print r3
+  pure ()
+
+testAsyncCommands :: IO ()
+testAsyncCommands = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right () <- runExceptT $ do
+    bobId <- createConnectionAsync alice True SCMInvitation
+    ("", _, INV (ACR _ qInfo)) <- get alice
+    aliceId <- joinConnectionAsync bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
+    allowConnectionAsync alice bobId confId "alice's connInfo"
+    get alice ##> ("", bobId, CON)
+    get bob ##> ("", aliceId, INFO "alice's connInfo")
+    get bob ##> ("", aliceId, CON)
+    -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
+    1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
+    get alice ##> ("", bobId, SENT $ baseId + 1)
+    2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
+    get alice ##> ("", bobId, SENT $ baseId + 2)
+    get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
+    ackMessageAsync bob aliceId $ baseId + 1
+    get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
+    ackMessageAsync bob aliceId $ baseId + 2
+    3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
+    get bob ##> ("", aliceId, SENT $ baseId + 3)
+    4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
+    get bob ##> ("", aliceId, SENT $ baseId + 4)
+    get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
+    ackMessageAsync alice bobId $ baseId + 3
+    get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
+    ackMessageAsync alice bobId $ baseId + 4
+  pure ()
+  where
+    baseId = 3
+    msgId = subtract baseId
+
+testAsyncCommandsRestore :: ATransport -> IO ()
+testAsyncCommandsRestore t = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  Right bobId <- runExceptT $ createConnectionAsync alice True SCMInvitation
+  liftIO $ noMessages alice "alice doesn't receive INV because server is down"
+  disconnectAgentClient alice
+  alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
+  withSmpServerStoreLogOn t testPort $ \_ -> do
+    Right () <- runExceptT $ do
+      subscribeConnection alice' bobId
+      ("", _, INV _) <- get alice'
+      pure ()
+    pure ()
+
 exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
-exchangeGreetings alice bobId bob aliceId = do
-  4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
-  get alice ##> ("", bobId, SENT 4)
+exchangeGreetings = exchangeGreetingsMsgId 4
+
+exchangeGreetingsMsgId :: 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
+  get alice ##> ("", bobId, SENT msgId)
   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
-  ackMessage bob aliceId 4
-  5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
-  get bob ##> ("", aliceId, SENT 5)
+  ackMessage bob aliceId msgId
+  msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
+  let msgId' = msgId + 1
+  liftIO $ msgId2 `shouldBe` msgId'
+  get bob ##> ("", aliceId, SENT msgId')
   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
-  ackMessage alice bobId 5
+  ackMessage alice bobId msgId'

tests/AgentTests/NotificationTests.hs

@@ -22,7 +22,6 @@ import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
 import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Client (AgentClient)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
@@ -211,9 +210,9 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right (bobId, aliceId, nonce, message) <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)
@@ -250,7 +249,8 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
     -- delete notification subscription
-    deleteNtfSub alice bobId
+    toggleConnectionNtfs alice bobId False
+    liftIO $ threadDelay 250000
     -- send message
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
@@ -272,34 +272,29 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
     _ <- registerTestToken bob "bcde" NMInstant apnsQ
     -- establish connection
     liftIO $ threadDelay 50000
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    liftIO $ threadDelay 500000
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    liftIO $ print 0
+    (bobId, qInfo) <- createConnection alice True SCMInvitation
+    liftIO $ threadDelay 1000000
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    liftIO $ threadDelay 750000
     void $ messageNotification apnsQ
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     liftIO $ threadDelay 500000
     allowConnection alice bobId confId "alice's connInfo"
-    liftIO $ print 1
     void $ messageNotification apnsQ
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-    liftIO $ print 2
     void $ messageNotification apnsQ
     get alice ##> ("", bobId, CON)
-    liftIO $ print 3
     void $ messageNotification apnsQ
     get bob ##> ("", aliceId, CON)
     -- bob sends message
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    liftIO $ print 4
     void $ messageNotification apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId $ baseId + 1
     -- alice sends message
     2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
     get alice ##> ("", bobId, SENT $ baseId + 2)
-    liftIO $ print 5
     void $ messageNotification apnsQ
     get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
     ackMessage bob aliceId $ baseId + 2
@@ -329,9 +324,9 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right () <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)
@@ -348,7 +343,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     -- set mode to NMPeriodic
     NTActive <- registerNtfToken alice tkn NMPeriodic
     -- send message, no notification
-    liftIO $ threadDelay 500000
+    liftIO $ threadDelay 750000
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     noNotification apnsQ
@@ -394,9 +389,9 @@ testChangeToken APNSMockServer {apnsQ} = do
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right (aliceId, bobId) <- runExceptT $ do
     -- establish connection
-    (bobId, qInfo) <- createConnection alice SCMInvitation
-    aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    (bobId, qInfo) <- createConnection alice True SCMInvitation
+    aliceId <- joinConnection bob True qInfo "bob's connInfo"
+    ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get alice ##> ("", bobId, CON)

tests/AgentTests/SQLiteTests.hs

@@ -27,6 +27,7 @@ import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Protocol as SMP
+import System.IO.Unsafe (unsafePerformIO)
 import System.Random
 import Test.Hspec
 import UnliftIO.Directory (removeFile)
@@ -139,7 +140,7 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {connId = "conn1", connAgentVersion = 1, duplexHandshake = Nothing}
+cData1 = ConnData {connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing}
 
 testPrivateSignKey :: C.APrivateSignKey
 testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -150,6 +151,9 @@ testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOp
 testDhSecret :: C.DhSecretX25519
 testDhSecret = "01234567890123456789012345678901"
 
+currentTime :: UTCTime
+currentTime = unsafePerformIO getCurrentTime
+
 rcvQueue1 :: RcvQueue
 rcvQueue1 =
   RcvQueue
@@ -159,9 +163,16 @@ rcvQueue1 =
       rcvDhSecret = testDhSecret,
       e2ePrivKey = testPrivDhKey,
       e2eDhSecret = Nothing,
-      sndId = Just "2345",
+      sndId = "2345",
+      sndPublicKey = Nothing,
       status = New,
-      clientNtfCreds = Nothing
+      currRcvQueue = True,
+      dbNextRcvQueueId = Nothing,
+      rcvQueueAction = Nothing,
+      clientNtfCreds = Nothing,
+      smpClientVersion = 1,
+      createdAt = currentTime,
+      updatedAt = currentTime
     }
 
 sndQueue1 :: SndQueue
@@ -173,7 +184,13 @@ sndQueue1 =
       sndPrivateKey = testPrivateSignKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
-      status = New
+      status = New,
+      currSndQueue = True,
+      dbNextSndQueueId = Nothing,
+      sndQueueAction = Nothing,
+      smpClientVersion = 1,
+      createdAt = currentTime,
+      updatedAt = currentTime
     }
 
 testCreateRcvConn :: SpecWith SQLiteStore
@@ -187,7 +204,7 @@ testCreateRcvConn =
     upgradeRcvConnToDuplex db "conn1" sndQueue1
       `shouldReturn` Right ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1 Nothing Nothing))
 
 testCreateRcvConnRandomId :: SpecWith SQLiteStore
 testCreateRcvConnRandomId =
@@ -199,7 +216,7 @@ testCreateRcvConnRandomId =
     upgradeRcvConnToDuplex db connId sndQueue1
       `shouldReturn` Right ()
     getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1 Nothing Nothing))
 
 testCreateRcvConnDuplicate :: SpecWith SQLiteStore
 testCreateRcvConnDuplicate =
@@ -220,7 +237,7 @@ testCreateSndConn =
     upgradeSndConnToDuplex db "conn1" rcvQueue1
       `shouldReturn` Right ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1 Nothing Nothing))
 
 testCreateSndConnRandomID :: SpecWith SQLiteStore
 testCreateSndConnRandomID =
@@ -232,7 +249,7 @@ testCreateSndConnRandomID =
     upgradeSndConnToDuplex db connId rcvQueue1
       `shouldReturn` Right ()
     getConn db connId
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1 Nothing Nothing))
 
 testCreateSndConnDuplicate :: SpecWith SQLiteStore
 testCreateSndConnDuplicate =
@@ -250,7 +267,7 @@ testGetRcvConn =
     g <- newTVarIO =<< drgNew
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getRcvConn db smpServer recipientId
-      `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
+      `shouldReturn` Right (rcvQueue1, SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
 
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
@@ -285,7 +302,7 @@ testDeleteDuplexConn =
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1 Nothing Nothing))
     deleteConn db "conn1"
       `shouldReturn` ()
     -- TODO check queues are deleted as well
@@ -305,7 +322,13 @@ testUpgradeRcvConnToDuplex =
               sndPrivateKey = testPrivateSignKey,
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
-              status = New
+              status = New,
+              currSndQueue = True,
+              dbNextSndQueueId = Nothing,
+              sndQueueAction = Nothing,
+              smpClientVersion = 1,
+              createdAt = currentTime,
+              updatedAt = currentTime
             }
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
       `shouldReturn` Left (SEBadConnType CSnd)
@@ -326,9 +349,16 @@ testUpgradeSndConnToDuplex =
               rcvDhSecret = testDhSecret,
               e2ePrivKey = testPrivDhKey,
               e2eDhSecret = Nothing,
-              sndId = Just "4567",
+              sndId = "4567",
+              sndPublicKey = Nothing,
               status = New,
-              clientNtfCreds = Nothing
+              currRcvQueue = False,
+              dbNextRcvQueueId = Nothing,
+              rcvQueueAction = Nothing,
+              clientNtfCreds = Nothing,
+              smpClientVersion = 1,
+              createdAt = currentTime,
+              updatedAt = currentTime
             }
     upgradeSndConnToDuplex db "conn1" anotherRcvQueue
       `shouldReturn` Left (SEBadConnType CRcv)
@@ -367,15 +397,15 @@ testSetQueueStatusDuplex =
     _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1 Nothing Nothing))
     setRcvQueueStatus db rcvQueue1 Secured
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 Nothing Nothing))
     setSndQueueStatus db sndQueue1 Confirmed
       `shouldReturn` ()
     getConn db "conn1"
-      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}))
+      `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed} Nothing Nothing))
 
 hw :: ByteString
 hw = encodeUtf8 "Hello world!"
@@ -430,7 +460,8 @@ mkSndMsgData internalId internalSndId internalHash =
       msgFlags = SMP.noMsgFlags,
       msgBody = hw,
       internalHash,
-      prevMsgHash = internalHash
+      prevMsgHash = internalHash,
+      currSndQueue = True
     }
 
 testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation

tests/NtfClient.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -23,12 +24,14 @@ import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
+import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -50,7 +53,7 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 import UnliftIO.Timeout (timeout)
 
-testHost :: HostName
+testHost :: NonEmpty TransportHost
 testHost = "localhost"
 
 ntfTestPort :: ServiceName
@@ -65,9 +68,10 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 ntfTestStoreLogFile :: FilePath
 ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 
-testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
-testNtfClient client =
-  runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
+testNtfClient client = do
+  Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
+  runTransportClient Nothing host ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -93,7 +97,12 @@ ntfServerCfg =
       -- CA certificate private key is not needed for initialization
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
-      certificateFile = "tests/fixtures/server.crt"
+      certificateFile = "tests/fixtures/server.crt",
+      -- stats config
+      logStatsInterval = Nothing,
+      logStatsStartTime = 0,
+      serverStatsLogFile = "tests/ntf-server-stats.daily.log",
+      serverStatsBackupFile = Nothing
     }
 
 withNtfServerStoreLog :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ThreadId -> m a) -> m a
@@ -127,7 +136,7 @@ withNtfServerOn t port' = withNtfServerThreadOn t port' . const
 withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
 withNtfServer t = withNtfServerOn t ntfTestPort
 
-runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
+runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => (THandle c -> m a) -> m a
 runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
 
 ntfServerTest ::
@@ -140,10 +149,10 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
   where
     tPut' h (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
-      Right () <- tPut h (sig, t')
+      [Right ()] <- tPut h [(sig, t')]
       pure ()
     tGet' h = do
-      (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
+      [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
 ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation

tests/NtfServerTests.hs

@@ -25,6 +25,8 @@ import ServerTests
     samplePubKey,
     sampleSig,
     signSendRecv,
+    tGet1,
+    tPut1,
     (#==),
     _SEND',
     pattern Resp,
@@ -69,15 +71,15 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
 sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
 sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right () <- tPut h (sgn, t)
-  tGet h
+  Right () <- tPut1 h (sgn, t)
+  tGet1 h
 
 signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
 signSendRecvNtf 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 () <- tPut h (Just sig, t)
-  tGet h
+  Right () <- tPut1 h (Just sig, t)
+  tGet1 h
 
 (.->) :: J.Value -> J.Key -> Either String ByteString
 v .-> key =
@@ -132,7 +134,7 @@ testNotificationSubscription (ATransport t) =
           notifierId `shouldBe` nId
           send' APNSRespOk
           -- receive message
-          Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet rh
+          Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh
           Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
           mId1 `shouldBe` msgId
           mTs `shouldBe` msgTs

tests/SMPAgentClient.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -9,8 +10,9 @@ module SMPAgentClient where
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
-import Network.Socket (HostName, ServiceName)
+import Network.Socket (ServiceName)
 import NtfClient (ntfTestPort)
 import SMPClient
   ( serverBracket,
@@ -25,7 +27,8 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
-import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
+import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.KeepAlive
@@ -33,7 +36,7 @@ import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
 
-agentTestHost :: HostName
+agentTestHost :: NonEmpty TransportHost
 agentTestHost = "localhost"
 
 agentTestPort :: ServiceName
@@ -55,14 +58,21 @@ testDB3 :: String
 testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
 
 smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
-smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> tGetRaw h
+smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
+  where
+    get h = do
+      t@(_, _, cmdStr) <- tGetRaw h
+      case parseAll networkCommandP cmdStr of
+        Right (ACmd SAgent CONNECT {}) -> get h
+        Right (ACmd SAgent DISCONNECT {}) -> get h
+        _ -> pure t
 
-runSmpAgentTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (c -> m a) -> m a
+runSmpAgentTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => (c -> m a) -> m a
 runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test
   where
     t = transport @c
 
-runSmpAgentServerTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> c -> m a) -> m a
+runSmpAgentServerTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => ((ThreadId, ThreadId) -> c -> m a) -> m a
 runSmpAgentServerTest test =
   withSmpServerThreadOn t testPort $
     \server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $
@@ -73,7 +83,7 @@ runSmpAgentServerTest test =
 smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
 smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
 
-runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
+runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
 runSmpAgentTestN agents test = withSmpServer t $ run agents []
   where
     run :: [(ServiceName, ServiceName, String)] -> [c] -> m a
@@ -81,7 +91,7 @@ runSmpAgentTestN agents test = withSmpServer t $ run agents []
     run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
     t = transport @c
 
-runSmpAgentTestN_1 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([c] -> m a) -> m a
+runSmpAgentTestN_1 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => Int -> ([c] -> m a) -> m a
 runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients []
   where
     run :: Int -> [c] -> m a
@@ -158,24 +168,31 @@ smpAgentTest1_1_1 test' =
 testSMPServer :: SMPServer
 testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
 
+testSMPServer2 :: SMPServer
+testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
+
 initAgentServers :: InitialAgentServers
 initAgentServers =
   InitialAgentServers
     { smp = L.fromList [testSMPServer],
-      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
+      ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
+      netCfg = defaultNetworkConfig {tcpTimeout = 500_000}
     }
 
+initAgentServers2 :: InitialAgentServers
+initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
+
 agentCfg :: AgentConfig
 agentCfg =
   defaultAgentConfig
     { tcpPort = agentTestPort,
-      tbqSize = 1,
+      tbqSize = 4,
       dbFile = testDB,
       smpCfg =
         defaultClientConfig
           { qSize = 1,
             defaultTransport = (testPort, transport @TLS),
-            tcpTimeout = 500_000
+            networkConfig = defaultNetworkConfig {tcpTimeout = 500_000}
           },
       ntfCfg =
         defaultClientConfig
@@ -207,14 +224,15 @@ withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort
 withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
 withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
-testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
+testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
+  Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost
+  runTransportClient Nothing useHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
       then client h
       else do
         error $ "wrong welcome message: " <> B.unpack line
 
-testSMPAgentClient :: (Transport c, MonadUnliftIO m) => (c -> m a) -> m a
+testSMPAgentClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (c -> m a) -> m a
 testSMPAgentClient = testSMPAgentClientOn agentTestPort

tests/SMPClient.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -13,7 +14,9 @@ import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.List.NonEmpty (NonEmpty)
 import Network.Socket
+import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
@@ -29,7 +32,7 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
 import UnliftIO.Timeout (timeout)
 
-testHost :: HostName
+testHost :: NonEmpty TransportHost
 testHost = "localhost"
 
 testPort :: ServiceName
@@ -44,15 +47,19 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 testStoreLogFile :: FilePath
 testStoreLogFile = "tests/tmp/smp-server-store.log"
 
+testStoreLogFile2 :: FilePath
+testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
+
 testStoreMsgsFile :: FilePath
 testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 
-testServerStatsFile :: FilePath
-testServerStatsFile = "tests/tmp/smp-server-stats.log"
+testServerStatsBackupFile :: FilePath
+testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 
-testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
-testSMPClient client =
-  runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
+testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
+testSMPClient client = do
+  Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
+  runTransportClient Nothing useHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -76,7 +83,8 @@ cfg =
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
       logStatsStartTime = 0,
-      serverStatsFile = Nothing,
+      serverStatsLogFile = "tests/smp-server-stats.daily.log",
+      serverStatsBackupFile = Nothing,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
@@ -87,10 +95,10 @@ withSmpServerStoreMsgLogOnV2 :: (MonadUnliftIO m, MonadRandom m) => ATransport -
 withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
 
 withSmpServerStoreMsgLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsFile = Just testServerStatsFile}
+withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsFile = Just testServerStatsFile}
+withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerConfigOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServerConfig -> ServiceName -> (ThreadId -> m a) -> m a
 withSmpServerConfigOn t cfg' port' =
@@ -120,10 +128,10 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const
 withSmpServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
 withSmpServer t = withSmpServerOn t testPort
 
-runSmpTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
+runSmpTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => (THandle c -> m a) -> m a
 runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
 
-runSmpTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([THandle c] -> m a) -> m a
+runSmpTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => Int -> ([THandle c] -> m a) -> m a
 runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
   where
     run :: Int -> [THandle c] -> m a
@@ -140,10 +148,10 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
   where
     tPut' h (sig, corrId, queueId, smp) = do
       let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
-      Right () <- tPut h (sig, t')
+      [Right ()] <- tPut h [(sig, t')]
       pure ()
     tGet' h = do
-      (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
+      [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
 smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation

tests/ServerTests.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -14,6 +15,7 @@ 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.IO.Class
 import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
@@ -69,15 +71,25 @@ pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
 sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
 sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
   let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right () <- tPut h (sgn, t)
-  tGet h
+  Right () <- tPut1 h (sgn, t)
+  tGet1 h
 
 signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
 signSendRecv 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 () <- tPut h (Just sig, t)
-  tGet h
+  Right () <- tPut1 h (Just sig, t)
+  tGet1 h
+
+tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
+tPut1 h t = do
+  [r] <- tPut h [t]
+  pure r
+
+tGet1 :: (ProtocolEncoding cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission cmd)
+tGet1 h = do
+  [r] <- tGet h
+  pure r
 
 (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
 (actual, expected) #== message = assertEqual message expected actual
@@ -110,7 +122,7 @@ testCreateSecureV2 _ =
       (ok1, OK) #== "accepts unsigned SEND"
       (sId1, sId) #== "same queue ID in response 1"
 
-      Resp "" _ (Msg mId1 msg1) <- tGet h
+      Resp "" _ (Msg mId1 msg1) <- tGet1 h
       (dec mId1 msg1, Right "hello") #== "delivers message"
 
       Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
@@ -134,13 +146,15 @@ testCreateSecureV2 _ =
       (ok2, OK) #== "secures queue"
       (rId2, rId) #== "same queue ID in response 3"
 
-      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
-      (err4, ERR AUTH) #== "rejects KEY if already secured"
+      Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub)
+      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
+      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub')
+      (err4, ERR AUTH) #== "rejects if secured with different key"
 
       Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
       (ok3, OK) #== "accepts signed SEND"
 
-      Resp "" _ (Msg mId2 msg2) <- tGet h
+      Resp "" _ (Msg mId2 msg2) <- tGet1 h
       (dec mId2 msg2, Right "hello again") #== "delivers message 2"
 
       Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
@@ -151,7 +165,7 @@ testCreateSecureV2 _ =
 
       let maxAllowedMessage = B.replicate maxMessageLength '-'
       Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
-      Resp "" _ (Msg mId3 msg3) <- tGet h
+      Resp "" _ (Msg mId3 msg3) <- tGet1 h
       (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
 
       let biggerMessage = B.replicate (maxMessageLength + 1) '-'
@@ -172,7 +186,7 @@ testCreateSecure (ATransport t) =
       (ok1, OK) #== "accepts unsigned SEND"
       (sId1, sId) #== "same queue ID in response 1"
 
-      Resp "" _ (Msg mId1 msg1) <- tGet h
+      Resp "" _ (Msg mId1 msg1) <- tGet1 h
       (dec mId1 msg1, Right "hello") #== "delivers message"
 
       Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
@@ -196,13 +210,15 @@ testCreateSecure (ATransport t) =
       (ok2, OK) #== "secures queue"
       (rId2, rId) #== "same queue ID in response 3"
 
-      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
-      (err4, ERR AUTH) #== "rejects KEY if already secured"
+      Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub)
+      (sPub', _) <- C.generateSignatureKeyPair C.SEd448
+      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub')
+      (err4, ERR AUTH) #== "rejects if secured with different key"
 
       Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
       (ok3, OK) #== "accepts signed SEND"
 
-      Resp "" _ (Msg mId2 msg2) <- tGet h
+      Resp "" _ (Msg mId2 msg2) <- tGet1 h
       (dec mId2 msg2, Right "hello again") #== "delivers message 2"
 
       Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
@@ -213,7 +229,7 @@ testCreateSecure (ATransport t) =
 
       let maxAllowedMessage = B.replicate maxMessageLength '-'
       Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
-      Resp "" _ (Msg mId3 msg3) <- tGet h
+      Resp "" _ (Msg mId3 msg3) <- tGet1 h
       (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
 
       let biggerMessage = B.replicate (maxMessageLength + 1) '-'
@@ -240,7 +256,7 @@ testCreateDelete (ATransport t) =
       Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello 2")
       (ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
 
-      Resp "" _ (Msg mId1 msg1) <- tGet rh
+      Resp "" _ (Msg mId1 msg1) <- tGet1 rh
       (dec mId1 msg1, Right "hello") #== "delivers message"
 
       Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF)
@@ -249,8 +265,7 @@ testCreateDelete (ATransport t) =
       Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, OFF)
       (err2, ERR AUTH) #== "rejects OFF with sender's ID"
 
-      Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, OFF)
-      (ok3, OK) #== "suspends queue"
+      Resp "cdab" rId2 (LEN 2) <- signSendRecv rh rKey ("cdab", rId, OFF)
       (rId2, rId) #== "same queue ID in response 2"
 
       Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello")
@@ -259,12 +274,16 @@ testCreateDelete (ATransport t) =
       Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, _SEND "hello")
       (err4, ERR AUTH) #== "reject unsigned SEND too"
 
-      Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF)
-      (ok4, OK) #== "accepts OFF when suspended"
+      Resp "bcda" _ (LEN _) <- signSendRecv rh rKey ("bcda", rId, OFF)
 
       Resp "cdab" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)
       (dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
 
+      Resp "abcd" _ (Msg mId3 msg3) <- signSendRecv rh rKey ("abcd", rId, ACK mId2)
+      (dec mId3 msg3, Right "hello 2") #== "deliver the next message on ACK"
+
+      Resp "bcda" _ (LEN 0) <- signSendRecv rh rKey ("bcda", rId, ACK mId3)
+
       Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL)
       (err5, ERR AUTH) #== "rejects DEL with wrong signature"
 
@@ -296,7 +315,7 @@ stressTest (ATransport t) =
     smpTest3 t $ \h1 h2 h3 -> do
       (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
       (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
-      rIds <- forM [1 .. 50 :: Int] . const $ do
+      rIds <- forM ([1 .. 50] :: [Int]) . const $ do
         Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)
         pure rId
       let subscribeQueues h = forM_ rIds $ \rId -> do
@@ -331,7 +350,7 @@ testDuplex (ATransport t) =
       Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
       -- "key ..." is ad-hoc, not a part of SMP protocol
 
-      Resp "" _ (Msg mId1 msg1) <- tGet alice
+      Resp "" _ (Msg mId1 msg1) <- tGet1 alice
       Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId1)
       Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
       (bobKey, strEncode bsPub) #== "key received from Bob"
@@ -344,7 +363,7 @@ testDuplex (ATransport t) =
       Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
       -- "reply_id ..." is ad-hoc, not a part of SMP protocol
 
-      Resp "" _ (Msg mId2 msg2) <- tGet alice
+      Resp "" _ (Msg mId2 msg2) <- tGet1 alice
       Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2)
       Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
       (bId, encode bSnd) #== "reply queue ID received from Bob"
@@ -353,7 +372,7 @@ testDuplex (ATransport t) =
       Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
       -- "key ..." is ad-hoc, not a part of  SMP protocol
 
-      Resp "" _ (Msg mId3 msg3) <- tGet bob
+      Resp "" _ (Msg mId3 msg3) <- tGet1 bob
       Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK mId3)
       Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
       (aliceKey, strEncode asPub) #== "key received from Alice"
@@ -361,13 +380,13 @@ testDuplex (ATransport t) =
 
       Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, _SEND "hi alice")
 
-      Resp "" _ (Msg mId4 msg4) <- tGet alice
+      Resp "" _ (Msg mId4 msg4) <- tGet1 alice
       Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK mId4)
       (aDec mId4 msg4, Right "hi alice") #== "message received from Bob"
 
       Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, _SEND "how are you bob")
 
-      Resp "" _ (Msg mId5 msg5) <- tGet bob
+      Resp "" _ (Msg mId5 msg5) <- tGet1 bob
       Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
       (bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
 
@@ -384,7 +403,7 @@ testSwitchSub (ATransport t) =
       Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, _SEND "test2, no ACK")
       (ok2, OK) #== "sent test message 2"
 
-      Resp "" _ (Msg mId1 msg1) <- tGet rh1
+      Resp "" _ (Msg mId1 msg1) <- tGet1 rh1
       (dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"
       Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
       (dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
@@ -393,12 +412,12 @@ testSwitchSub (ATransport t) =
       (dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
       Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
 
-      Resp "" _ end <- tGet rh1
+      Resp "" _ end <- tGet1 rh1
       (end, END) #== "unsubscribed the 1st TCP connection"
 
       Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, _SEND "test3")
 
-      Resp "" _ (Msg mId3 msg3) <- tGet rh2
+      Resp "" _ (Msg mId3 msg3) <- tGet1 rh2
       (dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
 
       Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK mId3)
@@ -441,7 +460,7 @@ testGetSubCommands t =
       Resp "1b" _ OK <- signSendRecv sh sKey ("1b", sId, _SEND "hello 3")
       Resp "1c" _ OK <- signSendRecv sh sKey ("1c", sId, _SEND "hello 4")
       -- both get the same if not ACK'd
-      Resp "" _ (Msg mId1 msg1) <- tGet rh1
+      Resp "" _ (Msg mId1 msg1) <- tGet1 rh1
       Resp "2" _ (Msg mId1' msg1') <- signSendRecv rh2 rKey ("2", rId, GET)
       (dec mId1 msg1, Right "hello 1") #== "received from queue via SUB"
       (dec mId1' msg1', Right "hello 1") #== "retrieved from queue with GET"
@@ -503,14 +522,14 @@ testWithStoreLog at@(ATransport t) =
         writeTVar notifierId nId
       Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
       Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
-      Resp "" _ (Msg mId1 msg1) <- tGet h
+      Resp "" _ (Msg mId1 msg1) <- tGet1 h
       (decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
-      Resp "" _ (NMSG _ _) <- tGet h1
+      Resp "" _ (NMSG _ _) <- tGet1 h1
 
       (sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
       atomically $ writeTVar senderId2 sId2
       Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
-      Resp "" _ (Msg mId2 msg2) <- tGet h
+      Resp "" _ (Msg mId2 msg2) <- tGet1 h
       (decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
 
       Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
@@ -535,7 +554,7 @@ testWithStoreLog at@(ATransport t) =
       Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
       Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
       (decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
-      Resp "" _ (NMSG _ _) <- tGet h1
+      Resp "" _ (NMSG _ _) <- tGet1 h1
       -- this queue is removed - not restored
       sId2 <- readTVarIO senderId2
       Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
@@ -576,7 +595,7 @@ testRestoreMessages at@(ATransport t) =
           writeTVar dhShared $ Just dh
           writeTVar senderId sId
         Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
-        Resp "" _ (Msg mId1 msg1) <- tGet h1
+        Resp "" _ (Msg mId1 msg1) <- tGet1 h1
         Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
         (decryptMsgV3 dh mId1 msg1, Right "hello") #== "message delivered"
       -- messages below are delivered after server restart
@@ -645,7 +664,7 @@ testRestoreMessagesV2 at@(ATransport t) =
           writeTVar dhShared $ Just dh
           writeTVar senderId sId
         Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
-        Resp "" _ (Msg mId1 msg1) <- tGet h1
+        Resp "" _ (Msg mId1 msg1) <- tGet1 h1
         Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
         (decryptMsgV2 dh mId1 msg1, Right "hello") #== "message delivered"
       -- messages below are delivered after server restart
@@ -710,14 +729,15 @@ testTiming :: ATransport -> Spec
 testTiming (ATransport t) =
   it "should have similar time for auth error, whether queue exists or not, for all key sizes" $
     smpTest2 t $ \rh sh ->
-      mapM_
-        (testSameTiming rh sh)
-        [ (32, 32, 200),
-          (32, 57, 100),
-          (57, 32, 200),
-          (57, 57, 100)
-        ]
+      mapM_ (testSameTiming rh sh) timingTests
   where
+    timingTests :: [(Int, Int, Int)]
+    timingTests =
+      [ (32, 32, 200),
+        (32, 57, 100),
+        (57, 32, 200),
+        (57, 57, 100)
+      ]
     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
     similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True
     testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
@@ -735,7 +755,7 @@ testTiming (ATransport t) =
       Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
 
       Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
-      Resp "" _ (Msg mId msg) <- tGet rh
+      Resp "" _ (Msg mId msg) <- tGet1 rh
       (dec mId msg, Right "hello") #== "delivered from queue"
 
       runTimingTest sh badKey sId $ _SEND "hello"
@@ -774,23 +794,23 @@ testMessageNotifications (ATransport t) =
       nId' `shouldNotBe` nId
       Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB)
       Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND' "hello")
-      Resp "" _ (Msg mId1 msg1) <- tGet rh
+      Resp "" _ (Msg mId1 msg1) <- tGet1 rh
       (dec mId1 msg1, Right "hello") #== "delivered from queue"
       Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
-      Resp "" _ (NMSG _ _) <- tGet nh1
+      Resp "" _ (NMSG _ _) <- tGet1 nh1
       Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
-      Resp "" _ END <- tGet nh1
+      Resp "" _ END <- tGet1 nh1
       Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
-      Resp "" _ (Msg mId2 msg2) <- tGet rh
+      Resp "" _ (Msg mId2 msg2) <- tGet1 rh
       Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
       (dec mId2 msg2, Right "hello again") #== "delivered from queue again"
-      Resp "" _ (NMSG _ _) <- tGet nh2
+      Resp "" _ (NMSG _ _) <- tGet1 nh2
       1000 `timeout` tGet @BrokerMsg nh1 >>= \case
         Nothing -> pure ()
         Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
       Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
       Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
-      Resp "" _ (Msg mId3 msg3) <- tGet rh
+      Resp "" _ (Msg mId3 msg3) <- tGet1 rh
       (dec mId3 msg3, Right "hello there") #== "delivered from queue again"
       1000 `timeout` tGet @BrokerMsg nh2 >>= \case
         Nothing -> pure ()