3.1.3

* nts: server stats

* ntf: collect stats, refactor

* rename property

* fixes

.gitignore

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

CHANGELOG.md

@@ -1,3 +1,36 @@
+# 3.1.0
+
+SMP server and agent:
+
+- SMP protocol v4: batching multiple server commands/responses in a transport block.
+
+# 3.0.0
+
+SMP server:
+
+- restore undeliverd messages when the server is restarted.
+- SMP protocol v3 to support push notification:
+  - updated SEND and MSG to add message flags (for notification flag that contros whether the notification is sent and for any future extensions) and to move message meta-data sent to the recipient into the encrypted envelope.
+  - update NKEY and NID to add e2e encryption keys (for the notification meta-data encryption between SMP server and the client), and update NMSG to include this meta-data.
+  - update ACK command to include message ID (to avoid acknowledging unprocessed message).
+  - add NDEL commands to remove notification subscription credentials from SMP queue.
+  - add GET command to receive messages without subscription - to be used in iOS notification service extension to receive messages without terminating app subscriptions.
+
+SMP agent:
+
+- new protocol for duplex connection handshake reducing traffic and connection time.
+- support for SMP notifications server and managing device token.
+- remove redundant FQDN validation from TLS handshake to prepare for access via Tor.
+- support for fully stopping agent and for termporary suspending agent operations.
+- improve management of duplicate message delivery.
+
+SMP notifications server v1.0:
+
+- SMP notifications protocol with version negotiation during handshake.
+- device token registration and verification (via background notification).
+- SMP notification subscriptions and push notifications via APNS.
+- restoring notification subscriptions when the server is restarted.
+
 # 2.3.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-rc.0",
+          serverVersion = "SMP notifications server v1.1.3",
           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 = 100000, -- 100ms
-                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

@@ -17,7 +17,8 @@ servers :: InitialAgentServers
 servers =
   InitialAgentServers
     { smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
-      ntf = []
+      ntf = [],
+      netCfg = NetworkConfig {socksProxy = Nothing, tcpTimeout = 5000000}
     }
 
 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.1.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -55,6 +55,7 @@ dependencies:
   - 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.

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.1.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -61,6 +61,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
@@ -127,6 +128,7 @@ library
     , 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 +136,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.*
@@ -188,6 +190,7 @@ executable ntf-server
     , 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 +198,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.*
@@ -249,6 +252,7 @@ executable smp-agent
     , 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 +260,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.*
@@ -310,6 +314,7 @@ executable smp-server
     , 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 +322,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.*
@@ -390,6 +395,7 @@ test-suite smp-server-test
     , 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 +404,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.hs

@@ -45,20 +45,26 @@ module Simplex.Messaging.Agent
     acceptContact,
     rejectContact,
     subscribeConnection,
+    subscribeConnections,
     getConnectionMessage,
     getNotificationMessage,
     resubscribeConnection,
+    resubscribeConnections,
     sendMessage,
     ackMessage,
     suspendConnection,
     deleteConnection,
+    getConnectionServers,
     setSMPServers,
     setNtfServers,
+    setNetworkConfig,
+    getNetworkConfig,
     registerNtfToken,
     verifyNtfToken,
     checkNtfToken,
     deleteNtfToken,
     getNtfToken,
+    getNtfTokenData,
     deleteNtfSub,
     activateAgent,
     suspendAgent,
@@ -78,6 +84,7 @@ import Data.Composition ((.:), (.:.))
 import Data.Functor (($>))
 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 (isJust)
 import qualified Data.Text as T
@@ -104,10 +111,10 @@ import Simplex.Messaging.Parsers (parse)
 import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta)
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (bshow, eitherToMaybe, liftE, liftError, tryError, unlessM, whenM, ($>>=))
+import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Random (randomR)
-import UnliftIO.Async (async, race_)
+import UnliftIO.Async (async, mapConcurrently, race_)
 import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -157,6 +164,10 @@ rejectContact c = withAgentEnv c .: rejectContact' c
 subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 subscribeConnection c = withAgentEnv c . subscribeConnection' c
 
+-- | Subscribe to receive connection messages from multiple connections, batching commands when possible
+subscribeConnections :: AgentErrorMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
+subscribeConnections c = withAgentEnv c . subscribeConnections' c
+
 -- | Get connection message (GET command)
 getConnectionMessage :: AgentErrorMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
 getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
@@ -168,6 +179,9 @@ getNotificationMessage c = withAgentEnv c .: getNotificationMessage' c
 resubscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
 
+resubscribeConnections :: AgentErrorMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
+resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
+
 -- | Send message to the connection (SEND command)
 sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
 sendMessage c = withAgentEnv c .:. sendMessage' c
@@ -183,6 +197,10 @@ suspendConnection c = withAgentEnv c . suspendConnection' c
 deleteConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 deleteConnection c = withAgentEnv c . deleteConnection' c
 
+-- | get servers used for connection
+getConnectionServers :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
+getConnectionServers c = withAgentEnv c . getConnectionServers' c
+
 -- | Change servers to be used for creating new queues
 setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
 setSMPServers c = withAgentEnv c . setSMPServers' c
@@ -190,6 +208,18 @@ setSMPServers c = withAgentEnv c . setSMPServers' c
 setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
 setNtfServers c = withAgentEnv c . setNtfServers' c
 
+-- | set SOCKS5 proxy on/off and optionally set TCP timeout
+setNetworkConfig :: AgentErrorMonad m => AgentClient -> NetworkConfig -> m ()
+setNetworkConfig c cfg' = do
+  cfg <- atomically $ do
+    swapTVar (useNetworkConfig c) cfg'
+  liftIO . when (socksProxy cfg /= socksProxy cfg') $ do
+    closeProtocolServerClients c smpCfg smpClients
+    closeProtocolServerClients c ntfCfg ntfClients
+
+getNetworkConfig :: AgentErrorMonad m => AgentClient -> m NetworkConfig
+getNetworkConfig = readTVarIO . useNetworkConfig
+
 -- | Register device notifications token
 registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
 registerNtfToken c = withAgentEnv c .: registerNtfToken' c
@@ -207,6 +237,9 @@ deleteNtfToken c = withAgentEnv c . deleteNtfToken' c
 getNtfToken :: AgentErrorMonad m => AgentClient -> m (DeviceToken, NtfTknStatus, NotificationsMode)
 getNtfToken c = withAgentEnv c $ getNtfToken' c
 
+getNtfTokenData :: AgentErrorMonad m => AgentClient -> m NtfToken
+getNtfTokenData c = withAgentEnv c $ getNtfTokenData' c
+
 -- | Delete notification subscription for connection
 deleteNtfSub :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
 deleteNtfSub c = withAgentEnv c . deleteNtfSub' c
@@ -259,6 +292,7 @@ processCommand c (connId, cmd) = case cmd of
   ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
   OFF -> suspendConnection' c connId $> (connId, OK)
   DEL -> deleteConnection' c connId $> (connId, OK)
+  CHK -> (connId,) . STAT <$> getConnectionServers' c connId
 
 newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequestUri c)
 newConn c connId cMode = do
@@ -389,19 +423,77 @@ subscribeConnection' c connId =
       ns <- asks ntfSupervisor
       atomically $ sendNtfSubCommand ns (connId, NSCCreate)
 
+subscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
+subscribeConnections' _ [] = pure M.empty
+subscribeConnections' c connIds = do
+  conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConn)
+  let (errs, cs) = M.mapEither id conns
+      errs' = M.map (Left . storeError) errs
+      (sndQs, rcvQs) = M.mapEither rcvOrSndQueue cs
+      sndRs = M.map (sndSubResult . fst) sndQs
+      srvRcvQs :: Map SMPServer (Map ConnId (RcvQueue, ConnData)) = M.foldlWithKey' addRcvQueue M.empty rcvQs
+  mapM_ (mapM_ (uncurry $ resumeMsgDelivery c) . sndQueue) cs
+  rcvRs <- mapConcurrently subscribe (M.assocs srvRcvQs)
+  ns <- asks ntfSupervisor
+  tkn <- readTVarIO (ntfTkn ns)
+  when (instantNotifications tkn) . void . forkIO $ sendNtfCreate ns rcvRs
+  let rs = M.unions $ errs' : sndRs : rcvRs
+  notifyResultError rs
+  pure rs
+  where
+    rcvOrSndQueue :: SomeConn -> Either (SndQueue, ConnData) (RcvQueue, ConnData)
+    rcvOrSndQueue = \case
+      SomeConn _ (DuplexConnection cData rq _) -> Right (rq, cData)
+      SomeConn _ (SndConnection cData sq) -> Left (sq, cData)
+      SomeConn _ (RcvConnection cData rq) -> Right (rq, cData)
+      SomeConn _ (ContactConnection cData rq) -> Right (rq, cData)
+    sndSubResult :: SndQueue -> Either AgentErrorType ()
+    sndSubResult sq = case status (sq :: SndQueue) of
+      Confirmed -> Right ()
+      Active -> Left $ CONN SIMPLEX
+      _ -> Left $ INTERNAL "unexpected queue status"
+    addRcvQueue :: Map SMPServer (Map ConnId (RcvQueue, ConnData)) -> ConnId -> (RcvQueue, ConnData) -> Map SMPServer (Map ConnId (RcvQueue, ConnData))
+    addRcvQueue m connId rq@(RcvQueue {server}, _) = M.alter (Just . maybe (M.singleton connId rq) (M.insert connId rq)) server m
+    subscribe :: (SMPServer, Map ConnId (RcvQueue, ConnData)) -> m (Map ConnId (Either AgentErrorType ()))
+    subscribe (srv, qs) = subscribeQueues c srv (M.map fst qs)
+    sendNtfCreate :: NtfSupervisor -> [Map ConnId (Either AgentErrorType ())] -> m ()
+    sendNtfCreate ns rcvRs =
+      forM_ (concatMap M.assocs rcvRs) $ \case
+        (connId, Right _) -> atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
+        _ -> pure ()
+    sndQueue :: SomeConn -> Maybe (ConnData, SndQueue)
+    sndQueue = \case
+      SomeConn _ (DuplexConnection cData _ sq) -> Just (cData, sq)
+      SomeConn _ (SndConnection cData sq) -> Just (cData, sq)
+      _ -> Nothing
+    notifyResultError :: Map ConnId (Either AgentErrorType ()) -> m ()
+    notifyResultError rs = do
+      let actual = M.size rs
+          expected = length connIds
+      when (actual /= expected) . atomically $
+        writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
+
 resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
 resubscribeConnection' c connId =
   unlessM
     (atomically $ hasActiveSubscription c connId)
     (subscribeConnection' c connId)
 
+resubscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
+resubscribeConnections' _ [] = pure M.empty
+resubscribeConnections' c connIds = do
+  let r = M.fromList . zip connIds . repeat $ Right ()
+  connIds' <- filterM (fmap not . atomically . hasActiveSubscription c) connIds
+  -- union is left-biased, so results returned by subscribeConnections' take precedence
+  (`M.union` r) <$> subscribeConnections' c connIds'
+
 getConnectionMessage' :: AgentMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
 getConnectionMessage' c connId = do
   whenM (atomically $ hasActiveSubscription c connId) . throwError $ CMD PROHIBITED
   withStore c (`getConn` connId) >>= \case
     SomeConn _ (DuplexConnection _ rq _) -> getQueueMessage c rq
     SomeConn _ (RcvConnection _ rq) -> getQueueMessage c rq
-    SomeConn _ ContactConnection {} -> throwError $ CMD PROHIBITED
+    SomeConn _ (ContactConnection _ rq) -> getQueueMessage c rq
     SomeConn _ SndConnection {} -> throwError $ CONN SIMPLEX
 
 getNotificationMessage' :: forall m. AgentMonad m => AgentClient -> C.CbNonce -> ByteString -> m (NotificationInfo, [SMPMsgMeta])
@@ -636,6 +728,16 @@ deleteConnection' c connId =
       ns <- asks ntfSupervisor
       atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
 
+getConnectionServers' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
+getConnectionServers' c connId = connServers <$> withStore c (`getConn` connId)
+  where
+    connServers :: SomeConn -> ConnectionStats
+    connServers = \case
+      SomeConn _ (RcvConnection _ RcvQueue {server}) -> ConnectionStats {rcvServers = [server], sndServers = []}
+      SomeConn _ (SndConnection _ SndQueue {server}) -> ConnectionStats {rcvServers = [], sndServers = [server]}
+      SomeConn _ (DuplexConnection _ RcvQueue {server = s1} SndQueue {server = s2}) -> ConnectionStats {rcvServers = [s1], sndServers = [s2]}
+      SomeConn _ (ContactConnection _ RcvQueue {server}) -> ConnectionStats {rcvServers = [server], sndServers = []}
+
 -- | Change servers to be used for creating new queues, in Reader monad
 setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
 setSMPServers' c = atomically . writeTVar (smpServers c)
@@ -745,6 +847,12 @@ getNtfToken' c =
     Just NtfToken {deviceToken, ntfTknStatus, ntfMode} -> pure (deviceToken, ntfTknStatus, ntfMode)
     _ -> throwError $ CMD PROHIBITED
 
+getNtfTokenData' :: AgentMonad m => AgentClient -> m NtfToken
+getNtfTokenData' c =
+  withStore' c getSavedNtfToken >>= \case
+    Just tkn -> pure tkn
+    _ -> throwError $ CMD PROHIBITED
+
 -- | Delete notification subscription for connection, in Reader monad
 deleteNtfSub' :: AgentMonad m => AgentClient -> ConnId -> m ()
 deleteNtfSub' _c connId = do
@@ -805,17 +913,18 @@ setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m ()
 setNtfServers' c = atomically . writeTVar (ntfServers c)
 
 activateAgent' :: AgentMonad m => AgentClient -> m ()
-activateAgent' c = atomically $ do
-  writeTVar (agentState c) ASActive
-  activate databaseOp
-  activate sndNetworkOp
-  activate msgDeliveryOp
-  activate rcvNetworkOp
-  activate ntfNetworkOp
+activateAgent' c = do
+  atomically $ writeTVar (agentState c) ASActive
+  mapM_ activate $ reverse agentOperations
   where
-    activate opSel = modifyTVar' (opSel c) $ \s -> s {opSuspended = False}
+    activate opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = False}
 
 suspendAgent' :: AgentMonad m => AgentClient -> Int -> m ()
+suspendAgent' c 0 = do
+  atomically $ writeTVar (agentState c) ASSuspended
+  mapM_ suspend agentOperations
+  where
+    suspend opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = True}
 suspendAgent' c@AgentClient {agentState = as} maxDelay = do
   state <-
     atomically $ do
@@ -985,7 +1094,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
                     parseMessage agentMsgBody >>= \case
                       AgentConnInfo connInfo ->
                         processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = []} False
-                      AgentConnInfoReply smpQueues connInfo -> do
+                      AgentConnInfoReply smpQueues connInfo ->
                         processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues} True
                       _ -> prohibited
                     where
@@ -995,7 +1104,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
                         confId <- withStore c $ \db -> do
                           setHandshakeVersion db connId agentVersion duplexHS
                           createConfirmation db g newConfirmation
-                        notify $ CONF confId connInfo
+                        let srvs = map (\SMPQueueInfo {smpServer = s} -> s) $ smpReplyQueues senderConf
+                        notify $ CONF confId srvs connInfo
                   _ -> prohibited
               -- party accepting connection
               (DuplexConnection _ _ sq, Nothing) -> do
@@ -1041,14 +1151,15 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
               _ -> prohibited
 
         smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
-        smpInvitation connReq cInfo = do
+        smpInvitation connReq@(CRInvitationUri crData _) cInfo = do
           logServer "<--" c srv rId "MSG <KEY>"
           case conn of
             ContactConnection {} -> do
               g <- asks idsDrg
               let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
               invId <- withStore c $ \db -> createInvitation db g newInv
-              notify $ REQ invId cInfo
+              let srvs = L.map (\SMPQueueUri {smpServer = s} -> s) $ crSmpQueues crData
+              notify $ REQ invId srvs cInfo
             _ -> prohibited
 
         checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity

src/Simplex/Messaging/Agent/Client.hs

@@ -19,8 +19,10 @@ module Simplex.Messaging.Agent.Client
     newAgentClient,
     withAgentLock,
     closeAgentClient,
+    closeProtocolServerClients,
     newRcvQueue,
     subscribeQueue,
+    subscribeQueues,
     getQueueMessage,
     decryptSMPMessage,
     addSubscription,
@@ -54,6 +56,7 @@ module Simplex.Messaging.Agent.Client
     AgentOperation (..),
     AgentOpState (..),
     AgentState (..),
+    agentOperations,
     agentOperationBracket,
     beginAgentOperation,
     endAgentOperation,
@@ -63,6 +66,7 @@ module Simplex.Messaging.Agent.Client
     whenSuspending,
     withStore,
     withStore',
+    storeError,
   )
 where
 
@@ -73,16 +77,19 @@ 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 Data.Text.Encoding
+import Data.Tuple (swap)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
 import Simplex.Messaging.Agent.Env.SQLite
@@ -102,10 +109,10 @@ import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, N
 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.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
 
@@ -124,6 +131,7 @@ data AgentClient = AgentClient
     smpClients :: TMap SMPServer SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfServer NtfClientVar,
+    useNetworkConfig :: TVar NetworkConfig,
     subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
     pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
     subscrConns :: TMap ConnId SMPServer,
@@ -155,13 +163,16 @@ agentOpSel = \case
   AOSndNetwork -> sndNetworkOp
   AODatabase -> databaseOp
 
+agentOperations :: [AgentClient -> TVar AgentOpState]
+agentOperations = [ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp]
+
 data AgentOpState = AgentOpState {opSuspended :: Bool, opsInProgress :: Int}
 
 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
@@ -171,6 +182,7 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
   smpClients <- TM.empty
   ntfServers <- newTVar ntf
   ntfClients <- TM.empty
+  useNetworkConfig <- newTVar netCfg
   subscrSrvrs <- TM.empty
   pendingSubscrSrvrs <- TM.empty
   subscrConns <- TM.empty
@@ -188,7 +200,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, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
 
 agentDbPath :: AgentClient -> FilePath
 agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
@@ -215,7 +227,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
   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)
 
@@ -261,34 +273,18 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
         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 (TM.lookup srv (pendingSubscrSrvrs 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 RcvQueue -> m ()
+        resubscribe qs = do
+          (errs, oks) <- M.mapEither id <$> subscribeQueues c srv qs
+          liftIO . unless (M.null oks) . notifySub "" . UP srv $ M.keys oks
+          let (tempErrs, finalErrs) = M.partition temporaryAgentError errs
+          liftIO . mapM_ (\(connId, e) -> notifySub connId $ ERR e) $ M.assocs finalErrs
+          mapM_ throwError . listToMaybe $ M.elems tempErrs
 
     notifySub :: ConnId -> ACommand 'Agent -> IO ()
     notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
@@ -303,7 +299,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
   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 ()
@@ -349,7 +345,7 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
           atomically $ putTMVar clientVar r
           successAction client
         Left e -> do
-          if e == BROKER NETWORK || e == BROKER TIMEOUT
+          if temporaryAgentError e
             then retryAction
             else atomically $ do
               putTMVar clientVar (Left e)
@@ -364,11 +360,16 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
       ri <- asks $ reconnectInterval . config
       withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
 
+updateClientConfig :: AgentClient -> ProtocolClientConfig -> STM ProtocolClientConfig
+updateClientConfig AgentClient {useNetworkConfig} cfg = do
+  NetworkConfig {socksProxy, tcpTimeout} <- readTVar useNetworkConfig
+  pure (cfg :: ProtocolClientConfig) {socksProxy, tcpTimeout}
+
 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 smpCfg smpClients
+  closeProtocolServerClients c ntfCfg ntfClients
   cancelActions $ reconnections c
   cancelActions $ asyncClients c
   cancelActions $ smpQueueMsgDeliveries c
@@ -379,13 +380,15 @@ closeAgentClient c = liftIO $ do
   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
 
-closeProtocolServerClients :: Int -> TMap (ProtoServer msg) (ClientVar msg) -> IO ()
-closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
+closeProtocolServerClients :: AgentClient -> (AgentConfig -> ProtocolClientConfig) -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO ()
+closeProtocolServerClients c cfgSel clientsSel =
+  readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
   where
+    cs = clientsSel c
+    ProtocolClientConfig {tcpTimeout} = cfgSel . config $ agentEnv c
     closeClient cVar =
       tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
@@ -472,14 +475,54 @@ subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
 subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = 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
+  withLogClient c server rcvId "SUB" $ \smp ->
+    liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq connId)
+      >>= either throwError pure
+
+processSubResult :: AgentClient -> RcvQueue -> ConnId -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
+processSubResult c rq@RcvQueue {server} connId r = do
+  case r of
+    Left e ->
+      atomically . unless (temporaryClientError e) $
+        removePendingSubscription c server connId
+    _ -> addSubscription c rq connId
+  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 RcvQueue -> m (Map ConnId (Either AgentErrorType ()))
+subscribeQueues c srv qs = do
+  (errs, qs_) <- partitionEithers <$> mapM checkQueue (M.assocs qs)
+  forM_ qs_ $ atomically . uncurry (addPendingSubscription c) . swap
+  case L.nonEmpty qs_ of
+    Just qs' -> do
+      smp_ <- tryError (getSMPServerClient c srv)
+      M.fromList . (errs <>) <$> case smp_ of
+        Left e -> pure $ map (second . const $ Left e) qs_
+        Right smp -> do
+          logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB"
+          let qs2 = L.map (queueCreds . snd) qs'
+          rs' :: [((ConnId, RcvQueue), Either ProtocolClientError ())] <-
+            liftIO $ zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
+          forM_ rs' $ \((connId, rq), r) -> liftIO $ processSubResult c rq connId r
+          pure $ map (bimap fst (first $ protocolClientError SMP)) rs'
+    _ -> pure $ M.fromList errs
+  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 -> m ()
 addSubscription c rq@RcvQueue {server} connId = atomically $ do
@@ -758,15 +801,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

@@ -1,5 +1,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
@@ -13,6 +15,7 @@ module Simplex.Messaging.Agent.Env.SQLite
   ( AgentMonad,
     AgentConfig (..),
     InitialAgentServers (..),
+    NetworkConfig (..),
     defaultAgentConfig,
     defaultReconnectInterval,
     Env (..),
@@ -26,9 +29,12 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Word (Word16)
+import GHC.Generics (Generic)
 import Network.Socket
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol
@@ -43,6 +49,7 @@ import Simplex.Messaging.Protocol (NtfServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TLS, Transport (..))
+import Simplex.Messaging.Transport.Client (SocksProxy, defaultSMPPort)
 import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async)
@@ -53,9 +60,20 @@ type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorTy
 
 data InitialAgentServers = InitialAgentServers
   { smp :: NonEmpty SMPServer,
-    ntf :: [NtfServer]
+    ntf :: [NtfServer],
+    netCfg :: NetworkConfig
   }
 
+data NetworkConfig = NetworkConfig
+  { socksProxy :: Maybe SocksProxy,
+    tcpTimeout :: Int
+  }
+  deriving (Show, Generic, FromJSON)
+
+instance ToJSON NetworkConfig where
+  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
+  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
     cmdSignAlg :: C.SignAlg,
@@ -67,7 +85,6 @@ data AgentConfig = AgentConfig
     ntfCfg :: ProtocolClientConfig,
     reconnectInterval :: RetryInterval,
     helloTimeout :: NominalDiffTime,
-    resubscriptionConcurrency :: Int,
     ntfCron :: Word16,
     ntfWorkerDelay :: Int,
     ntfSMPWorkerDelay :: Int,
@@ -99,11 +116,10 @@ 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,
       helloTimeout = 2 * nominalDay,
-      resubscriptionConcurrency = 16,
       ntfCron = 20, -- minutes
       ntfWorkerDelay = 100000, -- microseconds
       ntfSMPWorkerDelay = 500000, -- microseconds

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

@@ -44,6 +44,7 @@ module Simplex.Messaging.Agent.Protocol
     SAParty (..),
     MsgHash,
     MsgMeta (..),
+    ConnectionStats (..),
     SMPConfirmation (..),
     AgentMsgEnvelope (..),
     AgentMessage (..),
@@ -208,9 +209,9 @@ data ACommand (p :: AParty) where
   NEW :: 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
+  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
@@ -227,6 +228,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 +238,22 @@ deriving instance Eq (ACommand p)
 
 deriving instance Show (ACommand p)
 
+data ConnectionStats = ConnectionStats
+  { rcvServers :: [SMPServer],
+    sndServers :: [SMPServer]
+  }
+  deriving (Eq, Show, Generic)
+
+instance StrEncoding ConnectionStats where
+  strEncode ConnectionStats {rcvServers, sndServers} =
+    "rcv=" <> strEncodeList rcvServers <> " snd=" <> strEncodeList sndServers
+  strP = do
+    rcvServers <- "rcv=" *> strListP
+    sndServers <- " snd=" *> strListP
+    pure ConnectionStats {rcvServers, sndServers}
+
+instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
+
 data NotificationsMode = NMPeriodic | NMInstant
   deriving (Eq, Show)
 
@@ -747,7 +766,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
@@ -882,6 +901,8 @@ 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
@@ -889,9 +910,9 @@ commandP =
     newCmd = ACmd SClient . NEW <$> strP
     invResp = ACmd SAgent . INV <$> strP
     joinCmd = ACmd SClient .: JOIN <$> strP_ <*> A.takeByteString
-    confMsg = ACmd SAgent .: CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
+    confMsg = ACmd SAgent .:. CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> A.takeByteString
     letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
-    reqMsg = ACmd SAgent .: REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
+    reqMsg = ACmd SAgent .:. REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> A.takeByteString
     acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
     rjctCmd = ACmd SClient . RJCT <$> A.takeByteString
     infoCmd = ACmd SAgent . INFO <$> A.takeByteString
@@ -903,6 +924,7 @@ commandP =
     msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
     message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> A.takeByteString
     ackCmd = ACmd SClient . ACK <$> A.decimal
+    statResp = ACmd SAgent . STAT <$> strP
     connections = strP `A.sepBy'` A.char ','
     msgMetaP = do
       integrity <- strP
@@ -922,9 +944,9 @@ serializeCommand = \case
   NEW cMode -> "NEW " <> strEncode cMode
   INV cReq -> "INV " <> strEncode cReq
   JOIN cReq cInfo -> B.unwords ["JOIN", strEncode cReq, serializeBinary cInfo]
-  CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]
+  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
@@ -940,6 +962,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"
@@ -1012,9 +1036,9 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
       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
+      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/Store/SQLite/Migrations.hs

@@ -16,8 +16,8 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
 where
 
 import Control.Monad (forM_)
-import Data.Function (on)
 import Data.List (intercalate, sortBy)
+import Data.Ord (comparing)
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
 import Database.SQLite.Simple (Connection, Only (..), Query (..))
@@ -44,7 +44,7 @@ schemaMigrations =
 
 -- | 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}
 

src/Simplex/Messaging/Client.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -32,11 +33,14 @@ module Simplex.Messaging.Client
     -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
+    subscribeSMPQueues,
     getSMPMessage,
     subscribeSMPQueueNotifications,
     secureSMPQueue,
     enableSMPQueueNotifications,
     disableSMPQueueNotifications,
+    enableSMPQueuesNtfs,
+    disableSMPQueuesNtfs,
     sendSMPMessage,
     ackSMPMessage,
     suspendSMPQueue,
@@ -60,6 +64,10 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Either (rights)
+import Data.Functor (($>))
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Network.Socket (ServiceName)
 import Numeric.Natural
@@ -68,7 +76,7 @@ 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, runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
@@ -87,13 +95,16 @@ data ProtocolClient msg = ProtocolClient
     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)
 
@@ -107,6 +118,8 @@ data ProtocolClientConfig = ProtocolClientConfig
     tcpTimeout :: Int,
     -- | TCP keep-alive options, Nothing to skip enabling keep-alive
     tcpKeepAlive :: Maybe KeepAliveOpts,
+    -- | use SOCKS5 proxy
+    socksProxy :: Maybe SocksProxy,
     -- | period for SMP ping commands (microseconds)
     smpPing :: Int,
     -- | SMP client-server protocol version range
@@ -121,6 +134,7 @@ defaultClientConfig =
       defaultTransport = ("443", transport @TLS),
       tcpTimeout = 5_000_000,
       tcpKeepAlive = Just defaultKeepAliveOpts,
+      socksProxy = Nothing,
       smpPing = 600_000_000, -- 10min
       smpServerVRange = supportedSMPServerVRange
     }
@@ -138,7 +152,7 @@ type Response msg = Either ProtocolClientError msg
 -- 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 =
+getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, socksProxy, smpPing, smpServerVRange} msgQ disconnected =
   (atomically mkProtocolClient >>= runClient useTransport)
     `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
   where
@@ -169,7 +183,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
+          runTransportClient socksProxy (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
             `finally` atomically (putTMVar thVar $ Left PCENetworkError)
       th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case th_ of
@@ -208,13 +222,15 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
       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 +242,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 ()
@@ -285,12 +301,22 @@ 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 {} -> liftIO $ writeSMPMessage c rId cmd
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> ExceptT ProtocolClientError IO ()
-writeSMPMessage c rId msg =
-  liftIO . atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
+-- | Subscribe to multiple SMP queues batching commands if supported.
+subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either 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 {} -> writeSMPMessage c rId cmd $> Right ()
+      Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
+      Left e -> pure $ Left e
+
+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,9 +329,7 @@ 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) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Subscribe to the SMP queue notifications.
@@ -329,12 +353,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,7 +395,7 @@ 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 {} -> liftIO $ writeSMPMessage c rId cmd
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Irreversibly suspend SMP queue.
@@ -377,37 +421,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

@@ -30,7 +30,7 @@ import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPS
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (catchAll_, tryE, whenM, ($>>=))
+import Simplex.Messaging.Util (catchAll_, tryE, unlessM, ($>>=))
 import System.Timeout (timeout)
 import UnliftIO (async, forConcurrently_)
 import UnliftIO.Exception (Exception)
@@ -47,7 +47,7 @@ data SMPClientAgentEvent
   | CASubError SMPServer SMPSub ProtocolClientError
 
 data SMPSubParty = SPRecipient | SPNotifier
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 type SMPSub = (SMPSubParty, QueueId)
 
@@ -203,7 +203,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
         notify $ CAReconnected srv
         cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
         forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
-          whenM (atomically $ hasSub (srvSubs ca) srv s) $
+          unlessM (atomically $ hasSub (srvSubs ca) srv s) $
             subscribe_ smp sub `catchE` handleError s
       where
         subscribe_ :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()

src/Simplex/Messaging/Encoding.hs

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

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -412,6 +412,16 @@ data NtfSubStatus
     NSErr ByteString
   deriving (Eq, Show)
 
+ntfShouldSubscribe :: NtfSubStatus -> Bool
+ntfShouldSubscribe = \case
+  NSNew -> True
+  NSPending -> True
+  NSActive -> True
+  NSInactive -> True
+  NSEnd -> False
+  NSAuth -> False
+  NSErr _ -> False
+
 instance Encoding NtfSubStatus where
   smpEncode = \case
     NSNew -> "NEW"

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,40 @@ 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.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 (..), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
+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 +66,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,14 +89,62 @@ 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
-  forM_ subs $ \sub -> do
-    atomically $ writeTBQueue newSubQ $ NtfSub sub
-    threadDelay d
+  forM_ subs $ \sub@NtfSubData {} ->
+    whenM (ntfShouldSubscribe <$> readTVarIO (subStatus sub)) $ do
+      atomically $ writeTBQueue newSubQ $ NtfSub sub
+      threadDelay d
   liftIO $ logInfo "SMP connections resubscribed"
 
 ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
@@ -135,9 +197,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 ()
@@ -146,16 +211,19 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
       forever $
         atomically (readTBQueue agentQ) >>= \case
           CAConnected _ -> pure ()
-          CADisconnected srv subs ->
+          CADisconnected srv subs -> do
+            logInfo . T.pack $ "SMP server disconnected " <> host srv <> " (" <> show (length subs) <> ") subscriptions"
             forM_ subs $ \(_, ntfId) -> do
               let smpQueue = SMPQueueNtf srv ntfId
               updateSubStatus smpQueue NSInactive
-          CAReconnected _ -> pure ()
+          CAReconnected srv ->
+            logInfo $ "SMP server reconnected " <> T.pack (host srv)
           CAResubscribed srv sub -> do
             let ntfId = snd sub
                 smpQueue = SMPQueueNtf srv ntfId
             updateSubStatus smpQueue NSActive
-          CASubError srv (_, ntfId) err ->
+          CASubError srv (_, ntfId) err -> do
+            logError . T.pack $ "SMP subscription error on server " <> host srv <> ": " <> show err
             handleSubError (SMPQueueNtf srv ntfId) err
 
     handleSubError :: SMPQueueNtf -> ProtocolClientError -> m ()
@@ -188,18 +256,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 ())
@@ -244,22 +315,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
@@ -341,6 +413,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         atomically $ addNtfToken st tknId tkn
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
         withNtfLog (`logCreateToken` tkn)
+        incNtfStat tknCreated
         pure (corrId, "", NRTknId tknId srvDhPubKey)
       NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
@@ -362,6 +435,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               tIds <- atomically $ removeInactiveTokenRegistrations st tkn
               forM_ tIds cancelInvervalNotifications
               withNtfLog $ \s -> logTokenStatus s tknId NTActive
+              incNtfStat tknVerified
               pure NROk
             | otherwise -> do
               logDebug "TVFY - incorrect code or token status"
@@ -380,6 +454,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               addNtfToken st tknId tkn'
               writeTBQueue pushQ (tkn', PNVerification regCode)
             withNtfLog $ \s -> logUpdateToken s tknId token' regCode
+            incNtfStat tknDeleted
+            incNtfStat tknCreated
             pure NROk
           TDEL -> do
             logDebug "TDEL"
@@ -389,6 +465,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             cancelInvervalNotifications tknId
             withNtfLog (`logDeleteToken` tknId)
+            incNtfStat tknDeleted
             pure NROk
           TCRN 0 -> do
             logDebug "TCRN 0"
@@ -428,6 +505,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
@@ -448,6 +526,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
@@ -465,3 +544,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/Push/APNS.hs

@@ -99,6 +99,7 @@ data PushNotification
   | PNMessage PNMessageData
   | PNAlert Text
   | PNCheckMessages
+  deriving (Show)
 
 data PNMessageData = PNMessageData
   { smpQueue :: SMPQueueNtf,
@@ -106,6 +107,7 @@ data PNMessageData = PNMessageData
     nmsgNonce :: C.CbNonce,
     encNMsgMeta :: EncNMsgMeta
   }
+  deriving (Show)
 
 instance StrEncoding PNMessageData where
   strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =

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

@@ -1,7 +1,13 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Simplex.Messaging.Notifications.Transport where
 
 import Control.Monad.Except
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Version
 
@@ -11,13 +17,56 @@ ntfBlockSize = 512
 supportedNTFServerVRange :: VersionRange
 supportedNTFServerVRange = mkVersionRange 1 1
 
+data NtfServerHandshake = NtfServerHandshake
+  { ntfVersionRange :: VersionRange,
+    sessionId :: SessionId
+  }
+
+data NtfClientHandshake = NtfClientHandshake
+  { -- | agreed SMP notifications server protocol version
+    ntfVersion :: Version,
+    -- | server identity - CA certificate fingerprint
+    keyHash :: C.KeyHash
+  }
+
+instance Encoding NtfServerHandshake where
+  smpEncode NtfServerHandshake {ntfVersionRange, sessionId} =
+    smpEncode (ntfVersionRange, sessionId)
+  smpP = do
+    (ntfVersionRange, sessionId) <- smpP
+    pure NtfServerHandshake {ntfVersionRange, sessionId}
+
+instance Encoding NtfClientHandshake where
+  smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash)
+  smpP = do
+    (ntfVersion, keyHash) <- smpP
+    pure NtfClientHandshake {ntfVersion, keyHash}
+
 -- | Notifcations server transport handshake.
-ntfServerHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfServerHandshake c _ _ = pure $ ntfTHandle c
+ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+ntfServerHandshake c kh ntfVRange = do
+  let th@THandle {sessionId} = ntfTHandle c
+  sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange}
+  getHandshake th >>= \case
+    NtfClientHandshake {ntfVersion, keyHash}
+      | keyHash /= kh ->
+        throwError $ TEHandshake IDENTITY
+      | ntfVersion `isCompatible` ntfVRange -> do
+        pure (th :: THandle c) {thVersion = ntfVersion}
+      | otherwise -> throwError $ TEHandshake VERSION
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfClientHandshake c _ _ = pure $ ntfTHandle c
+ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+ntfClientHandshake c keyHash ntfVRange = do
+  let th@THandle {sessionId} = ntfTHandle c
+  NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th
+  if sessionId /= sessId
+    then throwError TEBadSession
+    else case ntfVersionRange `compatibleVersion` ntfVRange of
+      Just (Compatible ntfVersion) -> do
+        sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash}
+        pure (th :: THandle c) {thVersion = ntfVersion}
+      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 #-}
@@ -130,6 +131,8 @@ 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.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import Data.Maybe (isNothing)
 import Data.String
 import Data.Time.Clock.System (SystemTime (..))
@@ -664,7 +667,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)
@@ -1010,20 +1013,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 =
@@ -423,8 +432,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
           withLog (`logDeleteQueue` queueId)
           okResp <$> atomically (suspendQueue st queueId)
 
-        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 +455,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 +477,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 +486,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 +496,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 +512,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 +526,71 @@ 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
+                _ -> forkSub $> ok
             _ -> 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,7 +600,7 @@ 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}
@@ -714,7 +707,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 +716,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/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/Transport.hs

@@ -46,12 +46,15 @@ module Simplex.Messaging.Transport
     -- * SMP transport
     THandle (..),
     TransportError (..),
+    HandshakeError (..),
     smpServerHandshake,
     smpClientHandshake,
     tPutBlock,
     tGetBlock,
     serializeTransportError,
     transportErrorP,
+    sendHandshake,
+    getHandshake,
 
     -- * Trim trailing CR
     trimCR,
@@ -93,10 +96,10 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 3
+supportedSMPServerVRange = mkVersionRange 1 4
 
 simplexMQVersion :: String
-simplexMQVersion = "3.0.0-rc.0"
+simplexMQVersion = "3.1.3"
 
 -- * Transport connection class
 
@@ -255,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
@@ -361,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.
@@ -376,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
 
@@ -386,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

@@ -4,40 +4,58 @@ module Simplex.Messaging.Transport.Client
   ( runTransportClient,
     runTLSTransportClient,
     smpClientHandshake,
+    defaultSMPPort,
+    defaultSocksProxy,
+    SocksProxy,
   )
 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.Maybe (fromMaybe)
 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.String
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.KeepAlive
 import System.IO.Error
+import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
 
 -- | 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 -> HostName -> 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
+runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksProxy -> HostName -> 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_ host port keyHash
-  c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
+      connectTCP = maybe connectTCPClient connectSocksClient socksProxy_
+  c <- liftIO $ connectTLSClient connectTCP host port clientParams keepAliveOpts
   client c `E.finally` liftIO (closeConnection c)
 
-startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
-startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
+connectTLSClient :: forall c. Transport c => (HostName -> ServiceName -> IO Socket) -> HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
+connectTLSClient tcpClient host port clientParams keepAliveOpts = do
+  sock <- tcpClient host port
+  mapM_ (setSocketKeepAlive sock) keepAliveOpts
+  ctx <- connectTLS clientParams sock
+  getClientConnection ctx
+
+connectTCPClient :: HostName -> ServiceName -> IO Socket
+connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -47,20 +65,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 -> HostName -> ServiceName -> IO Socket
+connectSocksClient (SocksProxy addr) host _port = do
+  let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
+  fst <$> socksConnect (defaultSocksConf addr) (SocksAddress (SocksAddrDomainName $ B.pack host) 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

@@ -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 host port Nothing keepAliveOpts $ \c ->
     withTlsConfig c 16384 (`run` client)
   where
     run = H.run $ ClientConfig "https" (B.pack host) 20

src/Simplex/Messaging/Util.hs

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

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

@@ -126,7 +126,7 @@ testDuplexConnection _ alice bob = do
   ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW 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", 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)
@@ -159,7 +159,7 @@ testDuplexConnRandomIds _ alice bob = do
   ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW 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 <#:)
+  ("", 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")
@@ -193,9 +193,9 @@ testContactConnection _ alice bob tom = do
   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 <#:)
+  ("", "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)
@@ -206,9 +206,9 @@ testContactConnection _ alice bob tom = do
   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 <#:)
+  ("", "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)
@@ -224,11 +224,11 @@ testContactConnRandomIds _ alice bob = do
   let cReq' = strEncode cReq
 
   ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
-  ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
+  ("", 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)
@@ -246,7 +246,7 @@ testRejectContactRequest _ alice bob = do
   ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW 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 <#:)
+  ("", "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)
@@ -387,7 +387,7 @@ testConcurrentMsgDelivery _ alice bob = do
   ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW 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 <#:)
+  ("", "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")
@@ -426,7 +426,7 @@ connect (h1, name1) (h2, name2) = do
   ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
   let cReq' = strEncode cReq
   h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
-  ("", _, Right (CONF connId "info2")) <- (h1 <#:)
+  ("", _, Right (CONF connId _ "info2")) <- (h1 <#:)
   h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
   h2 <# ("", name1, INFO "info1")
   h2 <# ("", name1, CON)
@@ -447,7 +447,7 @@ sendMessage (h1, name1) (h2, name2) msg = do
 --   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")
 --   let cReq' = strEncode cReq
 --   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
---   ("", _, Right (REQ connId "info2")) <- (h1 <#:)
+--   ("", _, 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)

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, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
@@ -102,6 +106,9 @@ 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
 
 testAgentClient :: IO ()
 testAgentClient = do
@@ -156,7 +163,7 @@ 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
+    ("", _, 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")
@@ -192,9 +199,9 @@ 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
+    ("", _, REQ invId _ "bob's connInfo") <- get alice
     bobId <- acceptContact alice invId "alice's connInfo"
-    ("", _, CONF confId "alice's connInfo") <- get bob
+    ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
     get alice ##> ("", bobId, INFO "bob's connInfo")
     get alice ##> ("", bobId, CON)
@@ -243,7 +250,7 @@ testAsyncInitiatingOffline = do
     aliceId <- joinConnection bob 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")
@@ -259,7 +266,7 @@ testAsyncJoiningOfflineBeforeActivation = do
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob 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
@@ -280,7 +287,7 @@ testAsyncBothOffline = do
     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
@@ -309,7 +316,7 @@ testAsyncServerOffline t = do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
     aliceId <- joinConnection bob cReq "bob's connInfo"
-    ("", _, 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")
@@ -382,7 +389,7 @@ makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnI
 makeConnection alice bob = do
   (bobId, qInfo) <- createConnection alice SCMInvitation
   aliceId <- joinConnection bob qInfo "bob's connInfo"
-  ("", _, 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")
@@ -503,13 +510,64 @@ 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
+
 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

@@ -14,19 +14,21 @@ import Control.Concurrent (killThread, threadDelay)
 import Control.Monad.Except
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
-import Data.Bifunctor (bimap)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
-import SMPClient (withSmpServer)
+import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
+import Simplex.Messaging.Notifications.Types (NtfToken (..))
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (ATransport)
@@ -73,11 +75,15 @@ notificationTests t =
         withSmpServer t $
           withAPNSMockServer $ \apns ->
             withNtfServer t $ testChangeToken apns
-    describe "Notifications server store log" $ do
+    describe "Notifications server store log" $
       it "should save and restore tokens and subscriptions" $ \_ ->
         withSmpServer t $
           withAPNSMockServer $ \apns ->
             testNotificationsStoreLog t apns
+    describe "Notifications after SMP server restart" $
+      it "should resume subscriptions after SMP server is restarted" $ \_ ->
+        withAPNSMockServer $ \apns ->
+          withNtfServer t $ testNotificationsSMPRestart t apns
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
@@ -206,7 +212,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     -- establish connection
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, 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)
@@ -270,7 +276,7 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
     aliceId <- joinConnection bob qInfo "bob's connInfo"
     liftIO $ print 0
     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
@@ -324,7 +330,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     -- establish connection
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, 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)
@@ -389,7 +395,7 @@ testChangeToken APNSMockServer {apnsQ} = do
     -- establish connection
     (bobId, qInfo) <- createConnection alice SCMInvitation
     aliceId <- joinConnection bob qInfo "bob's connInfo"
-    ("", _, CONF confId "bob's connInfo") <- get alice
+    ("", _, 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)
@@ -430,8 +436,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
   alice <- getSMPAgentClient agentCfg initAgentServers
   bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
   Right (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
-    _ <- registerTestToken alice "abcd" NMInstant apnsQ
     (aliceId, bobId) <- makeConnection alice bob
+    _ <- registerTestToken alice "abcd" NMInstant apnsQ
     liftIO $ threadDelay 250000
     4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT 4)
@@ -452,6 +458,37 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
     liftIO $ killThread threadId
   pure ()
 
+testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
+testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
+  alice <- getSMPAgentClient agentCfg initAgentServers
+  bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
+  Right (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
+    (aliceId, bobId) <- makeConnection alice bob
+    _ <- registerTestToken alice "abcd" NMInstant apnsQ
+    liftIO $ threadDelay 250000
+    4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
+    get bob ##> ("", aliceId, SENT 4)
+    void $ messageNotification apnsQ
+    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+    ackMessage alice bobId 4
+    liftIO $ killThread threadId
+    pure (aliceId, bobId)
+
+  Right () <- runExceptT $ do
+    get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
+    get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
+
+  Right () <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
+    get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
+    get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
+    liftIO $ threadDelay 1000000
+    5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
+    get bob ##> ("", aliceId, SENT 5)
+    _ <- messageNotificationData alice apnsQ
+    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
+    liftIO $ killThread threadId
+  pure ()
+
 messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
 messageNotification apnsQ = do
   1000000 `timeout` atomically (readTBQueue apnsQ) >>= \case
@@ -463,6 +500,13 @@ messageNotification apnsQ = do
       pure (nonce, message)
     _ -> error "bad notification"
 
+messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
+messageNotificationData c apnsQ = do
+  (nonce, message) <- messageNotification apnsQ
+  NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
+  Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message)
+  pure pnMsgData
+
 noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
 noNotification apnsQ = do
   500000 `timeout` atomically (readTBQueue apnsQ) >>= \case

tests/NtfClient.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -67,7 +68,7 @@ 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 ->
+  runTransportClient Nothing testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -93,7 +94,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
@@ -140,10 +146,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

@@ -158,13 +158,20 @@ 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 = NetworkConfig {socksProxy = Nothing, tcpTimeout = 5000000}
     }
 
+initAgentServers2 :: InitialAgentServers
+initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
+
 agentCfg :: AgentConfig
 agentCfg =
   defaultAgentConfig
@@ -209,7 +216,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
 testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
+  runTransportClient Nothing agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
       then client h

tests/SMPClient.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -44,15 +45,18 @@ 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 ->
+  runTransportClient Nothing testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
     liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
@@ -76,7 +80,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 +92,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' =
@@ -140,10 +145,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)
@@ -140,7 +152,7 @@ testCreateSecureV2 _ =
       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 +163,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 +184,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)
@@ -202,7 +214,7 @@ testCreateSecure (ATransport t) =
       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 +225,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 +252,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)
@@ -296,7 +308,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 +343,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 +356,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 +365,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 +373,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 +396,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 +405,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 +453,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 +515,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 +547,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 +588,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 +657,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 +722,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 +748,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 +787,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 ()