ntf: measure batch size

* ntf: refactor smp worker (separate command processing into steps)

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>

CHANGELOG.md

@@ -1,3 +1,66 @@
+# 6.0.5
+
+SMP agent:
+- support generic SOCKS proxy (without isolate-by-auth).
+- reduce max message sizes
+
+# 6.0.4
+
+SMP server:
+- better performance/memory: fewer map updates on re-subscriptions (#1297), split and reduce STM transactions (#1294)
+- send DELD when subscribed queue is deleted (#1312)
+- add created/updated/used date to queues to manage expiration (#1306)
+
+XFTP server: truncate file creation time to 1 hour (#1310)
+
+Servers:
+- bind control port only to 127.0.0.1 for better security in case of firewall misconfiguration (#1280)
+- reduce memory used for period stats (#1298)
+
+Agent: process last notification from list (#1307)
+- report receive file error with redirected file ID, when redirect is present (#1304)
+- special error when deleted user record is not in database (#1303)
+- fix race when sending a message to the deleted connection (#1296)
+- support for multiple messages in a single notification
+
+Ntf server:
+- only use SOCKS proxy for servers without public address (#1314)
+
+# 6.0.3
+
+Agent:
+- fix possible stuck queue rotation (#1290).
+
+SMP server:
+- batch END responses when subscribed client switches to reduce server and client traffic.
+- reduce STM transactions for better performance.
+- add stats for END events and for SUB/DEL event batches.
+- remove "expensive" stats to save memory.
+
+# 6.0.2
+
+SMP agent:
+- fix stuck connection commands when a server is not responding.
+- store query errors, reduce slow query threshold to 1ms.
+
+Notification server:
+- reduce PING interval to 1 minute.
+- fix subscriptions disabled on race condition (only mark subscriptions with END status when received via the active connection).
+
+# 6.0.1
+
+SMP agent:
+- support changing user of the new connection.
+- do not start delivery workers when there are no messages to deliver.
+- enable notifications for all connections.
+- combine database transactions when subscribing.
+
+SMP server:
+- safe compacting of store log.
+- fix possible race when creating client that might lead to memory leak.
+
+Dependencies: upgrade tls to 1.9
+
 # 6.0.0
 
 Version 6.0.0.8

README.md

@@ -150,7 +150,7 @@ You can install and setup servers automatically using our script:
 
 ```sh
 curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
-&& if echo 'b8cf2be103f21f9461d9a500bcd3db06ab7d01d68871b07f4bd245195cbead1d simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
+&& if echo 'c90886104cd640b2ed64921dba80e90691db36788e8d6dcc13d8f33f92f0ea54 simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
 ```
 
 ### Build from source

apps/ntf-server/Main.hs

@@ -15,7 +15,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
 main :: IO ()
 main = do
-  setLogLevel LogDebug -- change to LogError in production
+  setLogLevel LogInfo
   cfgPath <- getEnvPath "NTF_SERVER_CFG_PATH" defaultCfgPath
   logPath <- getEnvPath "NTF_SERVER_LOG_PATH" defaultLogPath
   withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath

install.sh

@@ -3,8 +3,7 @@ set -eu
 
 # Links to scripts/configs
 bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
-bin_smp="$bin/smp-server-ubuntu-20_04-x86-64"
-bin_xftp="$bin/xftp-server-ubuntu-20_04-x86-64"
+remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
 
 scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
 scripts_systemd_smp="$scripts/smp-server.service"
@@ -26,6 +25,8 @@ path_conf_var="/var/opt"
 path_conf_smp="$path_conf_etc/simplex $path_conf_var/simplex"
 path_conf_xftp="$path_conf_etc/simplex-xftp $path_conf_var/simplex-xftp /srv/xftp"
 
+path_conf_info="$path_conf_etc/simplex-info"
+
 path_systemd="/etc/systemd/system"
 path_systemd_smp="$path_systemd/smp-server.service"
 path_systemd_xftp="$path_systemd/xftp-server.service"
@@ -65,7 +66,13 @@ ${GRN}4.${NC} Create systemd services:
 ${GRN}5.${NC} Install stopscript (systemd), update and uninstallation script:
     - all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}, ${YLW}${path_bin_stopscript}${NC}
 
-Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
+Press:
+  - ${GRN}ENTER${NC} to continue installing both xftp and smp servers
+  - ${GRN}1${NC} to install only smp server
+  - ${GRN}2${NC} to install only xftp server
+  - ${RED}Ctrl+C${NC} to cancel installation
+  
+Selection: "
 
 end="Installtion is complete!
 
@@ -76,27 +83,64 @@ Please checkout our server guides:
 To uninstall with full clean-up, simply run: ${YLW}sudo /usr/local/bin/simplex-servers-uninstall${NC}
 "
 
+os_test() {
+ . /etc/os-release
+
+ case "$VERSION_ID" in
+  20.04|22.04) : ;;
+  24.04) VERSION_ID='22.04' ;;
+  *) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
+ esac
+
+ version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
+ arch="$(uname -p)"
+
+ case "$arch" in
+  x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
+  *)  printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
+ esac
+
+ bin_smp="$bin/smp-server-ubuntu-${version}-${arch}"
+ bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}"
+}
+
 setup_bins() {
- curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
- curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
+ eval "bin=\$bin_${1}"
+ eval "path=\$path_bin_${1}"
+
+ curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path" && chmod +x "$path"
+
+ unset bin path
 }
 
 setup_users() {
- useradd -M "$user_smp" 2> /dev/null || true
- useradd -M "$user_xftp" 2> /dev/null || true
+ eval "user=\$user_${1}"
+
+ useradd -M "$user" 2> /dev/null || true
+
+ unset user
 }
 
 setup_dirs() {
  # Unquoted varibles, so field splitting can occur
- mkdir -p $path_conf_smp
- chown "$user_smp":"$user_smp" $path_conf_smp
- mkdir -p $path_conf_xftp
- chown "$user_xftp":"$user_xftp" $path_conf_xftp
+ eval "path_conf=\$path_conf_${1}"
+ eval "user=\$user_${1}"
+
+ mkdir -p $path_conf
+ mkdir -p $path_conf_info
+ printf "local_version_%s='%s'\n" "$1" "$remote_version" >> "$path_conf_info/release"
+ chown -R "$user":"$user" $path_conf
+
+ unset path_conf user
 }
 
 setup_systemd() {
- curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_systemd_smp"
- curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_systemd_xftp"
+ eval "scripts_systemd=\$scripts_systemd_${1}"
+ eval "path_systemd=\$path_systemd_${1}"
+
+ curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_systemd"
+
+ unset scripts_systemd path_systemd
 }
 
 setup_scripts() {
@@ -110,32 +154,62 @@ checks() {
   printf "This script is intended to be run with root privileges. Please re-run script using sudo."
   exit 1
  fi
+ 
+ os_test
+
+ mkdir -p $path_conf_info  
 }
 
 main() {
  checks
  
- printf "%b\n%b\n" "${BLU}$logo${NC}" "$welcome"
+ printf "%b\n%b" "${BLU}$logo${NC}" "$welcome"
  read ans
 
+ if [ "$ans" = '1' ]; then
+  setup='smp'
+ elif [ "$ans" = '2' ]; then
+  setup='xftp'
+ else
+  setup='smp xftp'
+ fi
+
  printf "Installing binaries..."
- setup_bins
+ 
+ for i in $setup; do
+  setup_bins "$i"
+ done
+ 
  printf "${GRN} Done!${NC}\n"
 
  printf "Creating users..."
- setup_users
+
+ for i in $setup; do
+  setup_users "$i"
+ done
+
  printf "${GRN} Done!${NC}\n"
  
  printf "Creating directories..."
- setup_dirs
+
+ for i in $setup; do
+  setup_dirs "$i"
+ done
+
  printf "${GRN} Done!${NC}\n"
 
  printf "Creating systemd services..."
- setup_systemd
+
+ for i in $setup; do
+  setup_systemd "$i"
+ done
+
  printf "${GRN} Done!${NC}\n"
 
  printf "Installing stopscript, update and uninstallation script..."
+
  setup_scripts
+
  printf "${GRN} Done!${NC}\n"
 
  printf "%b" "$end"

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 6.0.0.8
+version: 6.1.0.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -47,6 +47,7 @@ dependencies:
   - direct-sqlcipher == 2.3.*
   - directory == 1.3.*
   - filepath == 1.4.*
+  - hashable == 1.4.*
   - hourglass == 0.2.*
   - http-types == 0.12.*
   - http2 >= 4.2.2 && < 4.3
@@ -69,7 +70,7 @@ dependencies:
   - temporary == 1.3.*
   - time == 1.12.*
   - time-manager == 0.0.*
-  - tls >= 1.7.0 && < 1.8
+  - tls >= 1.9.0 && < 1.10
   - transformers == 0.6.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*

protocol/xrcp.md

@@ -67,7 +67,7 @@ The session invitation contains this data:
 - CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
 - Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
 - Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
-- Session X25519 DH key and SNTRUP761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
+- Session X25519 DH key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
 
 Host application decrypts (except the first session) and validates the invitation:
 - Session signature is valid.
@@ -184,7 +184,7 @@ The controller decrypts (including the first session) and validates the received
 The controller should reply with with `ctrlHello` or `ctrlError` response:
 
 ```abnf
-ctrlHello = %s"HELLO " kemCiphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
+ctrlHello = %s"HELLO " kemCiphertext encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
 ; ctrlHelloJSON is encrypted with the hybrid secret,
 ; including both previously agreed DH secret and KEM secret from kemCiphertext
 unpaddedSize = largeLength
@@ -206,6 +206,8 @@ JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`:
 }
 ```
 
+Controller `hello` block and all subsequent protocol messages are encrypted with the chain keys derived from the hybrid key (see key exchange below) - that is why conntroller hello block does not include nonce. That provides forward secrecy within the XRCP session. Receiving this `hello` block allows host to compute the same hybrid keys and to derive the same chain keys.
+
 Once the controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections.
 
 ### Controller/host session operation
@@ -223,10 +225,12 @@ tlsunique channel binding from TLS session MUST be included in commands (include
 The syntax for encrypted command and response body encoding:
 
 ```abnf
-commandBody = encBody sessSignature idSignature [attachment]
-responseBody = encBody [attachment] ; counter must match command
-encBody = nonce encLength32 encrypted(tlsunique counter body)
-attachment = %x01 nonce encLength32 encrypted(attachment)
+commandBody = counter encBody sessSignature idSignature [attachment]
+responseBody = counter encBody [attachment] ; counter must match command
+; counter is placed outside of encrypted body to allow correlating encryption keys
+; with the chain keys (each command and response are encrypted by different keys)
+encBody = encLength32 encrypted(tlsunique body)
+attachment = %x01 encLength32 encrypted(attachment)
 noAttachment = %x00
 tlsunique = length 1*OCTET
 counter = 8*8 OCTET ; int64
@@ -239,7 +243,7 @@ If the command or response includes attachment, its hash must be included in com
 
 Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted.
 
-This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
+This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA3-256 over concatenated DH shared secret and KEM encapsulated secret) to derive keys for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
 
 During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secret from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement.
 
@@ -250,7 +254,7 @@ In pseudo-code:
 ```
 // session 1
 hostHelloSecret(1) = dhSecret(1)
-sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
+sessionSecret(1) = sha3-256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
 dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1))
 kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1))
 // kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO
@@ -262,7 +266,7 @@ dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n))
 
 // session n
 hostHelloSecret(n) = dhSecret(n)
-sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
+sessionSecret(n) = sha3-256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
 dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n))
 // controllerDhKey(n) is either from invitation or from multicast announcement
 kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n))
@@ -273,6 +277,22 @@ If controller fails to store the new host DH key after receiving HELLO block, th
 
 To decrypt a multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers.
 
+Once kemSecret is agreed for the session, it is used to derive two chain keys, to receive and to send messages:
+
+```
+host: sndKey, rcvKey = HKDF(kemSecret, "SimpleXSbChainInit", 64)
+controller: rcvKey, sndKey  = HKDF(kemSecret, "SimpleXSbChainInit", 64)
+```
+
+where HKDF is based on SHA512, with empty salt.
+
+Actual keys and nonces to encrypt and decrypt messages are derived from these chain keys:
+
+```
+to send: (sndKey', sk, nonce) = HKDF(sndKey, "SimpleXSbChain", 88)
+to receive: (rcvKey', sk, nonce) = HKDF(rcvKey, "SimpleXSbChain", 88)
+```
+
 ## Threat model
 
 #### A passive network adversary able to monitor the site-local traffic:

rfcs/2021-09-01-smp-message-storage.md

@@ -0,0 +1,179 @@
+# SMP server message storage
+
+## Problem
+
+Currently SMP servers store all queues in server memory. As the traffic grows, so does the number of undelivered messages. What is worse, Haskell is not avoiding heap fragmentation when messages are allocated and then de-allocated - undelivered messages use ByteString and GC cannot move them around, as they use pinned memory.
+
+## Possible solutions
+
+### Solution 1: solve only GC fragmentation problem
+
+Move from ByteString to some other primitive to store messages in memory long term, e.g. ShortByteString, or manage allocation/de-allocation of stored messages manually in some other way.
+
+Pros: the simplest solution that avoids substantial re-engineering of the server.
+
+Cons:
+- not a long term solution, as memory growth still has limits.
+- may be ineffective, as it introduces additional copying of bytes.
+
+### Solution 2: move message storage to hard drive
+
+Use files or RocksDB to store messages.
+
+Pros:
+- much lower memory usage.
+- no message loss in case of abnormal server termination (important until clients have delivery redundancy).
+- this is a long term solution, and at some point it might need to be done anyway.
+
+Cons:
+- substantial re-engineering costs and risks.
+- metadata privacy. Currently we only save undelivered messages when server is restarted, with this approach all messages will be stored for some time. this argument is limited, as hosting providers of VMs can make memory snapshots too, on the other hand they are harder to analyze than files. On another hand, with this approach messages will be stored for a shorter time.
+
+#### RocksDB and other key-value stores
+
+The downside of any key-value stores is that they don't seem to have efficient primitives for sequential delivery. While sequential delivery can be modelled with linked lists, they would require 1 key insert (on send), 3 key updates (1 update to update queue data on send, 1 update of the last message to point to the next, 1 update on delivery or message expiration) and 1 key deletion (on delivery or message expiration) for each delivered message.
+
+This might result in substantial write amplification and compacting costs.
+
+In general, tree structures that are efficient for quick lookups and updates, given approximately fixed value size, are inefficient for modelling queues.
+
+#### Files
+
+The upside of files is that they are well suited for sequential delivery and don't result in the same churn, with careful design, as trees do.
+
+The downside of filesystem is that it does not scale well with the large number of files in a folder, so queues will have to be spread across multiple folders, following tree-like structure.
+
+I could not find an available library that efficiently models sequential delivery in highly concurrent environment.
+
+A possible design could be the following.
+
+##### Queue folder and files
+
+Each message queue is stored in its own folder (see below on folder locations). Folder would contain these files:
+
+- `messages.abcd.log` - the file that is used to read messages from, sequentially
+- `messages.efgh.log` - the optional file that is used to write messages, in case it is different from read file.
+- `queue.log` - append-only file where the last line represents the current queue state
+- `queue.timestamp.log` - previous states of queue.log file
+
+Each line in "queue.log" file has this syntax
+
+```abnf
+queueLogLine =
+    %s"read_file=" base64
+    %s"read_msg=" digits
+    %s"read_byte=" digits
+    %s"write_file=" base64
+    %s"write_msg=" digits
+```
+
+When queue is first requested by the server:
+
+```c
+if queue folder exists:
+    read queue state from last line of queue.log
+    if queue.log contained more than one line: // compaction
+        copy queue.log to queue.timestamp.log
+        write one line queue state to queue.log
+else:
+    create queue folder
+    create messages.abcd.log (abcd is some random string)
+    read_msg = 0
+    read_byte = 0
+    create queue.log with one line: "read_file=abcd read_msg=0 read_byte=0 write_files=abcd write_msg=0"
+open read_file in ReadMode and seek to read_byte position
+nextReadByte = read_byte
+nextReadMsg = read_msg
+open write_file in AppendMode
+```
+
+When message is added to the queue (assumes that queue state is loaded to server memory, if not the previous section will be done first):
+
+```c
+if write_msg > max_queue_messages:
+    return quota error
+else if write_msg = max_queue_messages:
+    add quota_exceeded message to write_file
+    update queue state: write_msg += 1
+    append updated queue state to queue.log
+else ]
+    // It is required that `max_queue_messages < max_file_messages`,
+    // so that we never need more than one additional write file.
+    if write_msg >= max_file_messages: // queue file rotation
+        create messages.efgh.log // efgh is some random string
+        update queue state: write_file=efgh write_msg=0 // read file remains the same as it was
+        append updated queue state to queue.log
+        copy queue.log to queue.timestamp.log
+        // `old` needs to be defined to limit the number and storage duration,
+        // preserving not more than N files, and not more than M days files, "and then some"
+        // (that is if the queue has high churn, we have file from M days before in any case, for any debugging).
+        delete `old` `queue.timestamp.log` files
+        write one line queue state to queue.log // compaction
+
+    add message to write_file
+    update queue state: write_msg += 1
+    append updated queue state to queue.log
+```
+
+The above algorithm assumes `max_queue_messages < than max_file_messages`, so that we never need more than one write file.
+
+When message is delivered, it is simply read from the read queue, queue state does not change yet:
+
+```c
+if nextReadMsg > read_msg:
+    deliver cached message, no need to read it again
+else
+    read message from read_file handle
+    nextReadMsg = read_msg + 1
+    nextReadByte = current position in file
+```
+
+When message delivery is acknowledged, the read queue needs to be advanced, and possibly switched to read from the current write_queue:
+
+```c
+if nextReadByte == read_byte:
+    return error // nothing was delivered
+else if nextReadByte = EOF:
+    // end of file is reached, possibly some other condition,
+    // but it should allow changing max_file_messages on server restart
+    currReadFile = read_file
+    read_file = write_file
+    read_msg = 0
+    read_byte = 0
+    append updated queue state to queue.log
+    delete currReadFile
+else
+    read_msg += 1
+    read_byte = nextReadByte
+    // `seek` should not be necessary, as the handle is already at nextReadByte position here
+    // seek to read_byte
+    append updated queue state to queue.log
+```
+
+The above algorithm delegates the problem of compaction and fragmentation management to file system, that is very optimized for such scenarios.
+
+Also, read and write files will grow to almost a constant size, so the space they used may be re-used.
+
+An important consideration is that writes to queue.log and message.log files and queue state modifications have to be sequential, without concurrency - it can be managed with the usual locks.
+
+##### Queue folders structure
+
+Most Linux systems use EXT4 filesystem where the file lookup time scales linearly to the number of files. While alternatives with logarithmic lookup time exist (XFS), they may be very complex to configure on the existing systems.
+
+So storing all queue folders in one folder won't scale.
+
+To solve this problem we could use recipient queue ID in base64url format not as a folder name, but as a folder path, splitting it to path fragments of some length. The number of fragments can be configurable and migration to a different fragment size can be supported as the number of queues on a given server grows.
+
+Currently, queue ID is 24 bytes random number, thus allowing 2^192 possible queue IDs. If we assume that a server must hold 1b queues, it means that we have ~2^162 possible addresses for each existing queue. 24 bytes in base64 is 32 characters that can be split into say 8 fragments with 4 characters each, so that queue folder path for queue with ID `abcdefghijklmnopqrstuvwxyz012345` would be:
+
+`/var/opt/simplex/messages/abcd/efgh/ijkl/mnop/qrst/uvwx/yz01/2345`
+
+The maximum theoretic number of the folders on the 1st level is 64^4, or 2^24 ~ 16m - this is probably still a large number of subfolders for EXT4. Given that addresses are random, all the possible combinations in the first folder can be used with a large number of queues.
+
+So we could use an unequal split of path, two letters each and the last being long:
+
+`/var/opt/simplex/messages/ab/cd/ef/ghijklmnopqrstuvwxyz012345`
+
+The first three levels in this case can have 4096 subfolders each, and it gives 68b possible subfolders (64^2^3), so the last level will be sparse in case of 1b queues on the server. So we could make it 4 levels with 2 letters to never think about it, accounting for a large variance of the random numbers distribution:
+
+`/var/opt/simplex/messages/ab/cd/ef/gh/ijklmnopqrstuvwxyz012345`

rfcs/2024-06-21-short-links.md

@@ -0,0 +1,124 @@
+# Short invitation links
+
+## Problem
+
+Long links look scary and unsafe for many users. While this is a perceived problem, rather than a real one, it hurts adoption.
+
+What is worse, long links do not fit in profile descriptions of other social networks where people might want to advertize their contact addresses.
+
+The current link size limitation is also the reason for not including PQ KEM keys into invitation links and addresses, postponing the moment when PQ-resistant encryption kicks in - if we include PQ KEM key into the link, the QR code will not be scannable.
+
+Additionally, if we store short links, they can also include chat preferences and public profile data.
+
+## Solution
+
+MITM-resistant link shortening.
+
+Instead of generating the random address that would resolve into the link - doing so would create the possibility of MITM by the server hosting this link - we can use private key as the link ID that will be passed to the accepting party, and the hash of the public key as ID for the server - the accepting party would present this key itself as ID and it will also be used for server to client encryption (see Protocol below). HKDF will be used to derive symmetric key from private key and used in secret_box together with random nonce (to allow replacing data with the same key but with a different nonce - nonce will be sent to the server too). secret_box construction is authenticated encryption, so it would protect from MITM.
+
+The proposed syntax:
+
+```abnf
+shortConnectionRequest = connectionScheme "/" connReqType "#/" smpServer "/" linkHash
+connReqType = %s"invitation" / %s"contact"
+connectionScheme = (%s"https://" clientAppServer) / %s"simplex:"
+clientAppServer = hostname [ ":" port ]
+  ; client app server, e.g. simplex.chat
+smpServer = serverIdentity "@" srvHosts [":" port] ; no smp:// prefix, no escaping
+srvHosts = <hostname> ["," srvHosts] ; RFC1123, RFC5891
+linkHash = <base64url encoded SHA256 or SHA512 hash of the original link>
+```
+
+If SMP server supports pages, its name can be used as clientAppServer, without repeating it after #, for a shorter link.
+
+Example link:
+
+```
+https://simplex.chat/contact/#[email protected]/abcdefghij0123456789abcdefghij0123456789abc=
+```
+
+This link has the length of ~136 characters (256 bits), which is shorter than the full contact address (~310 characters) and much shorter than invitation links (~528 characters) even without post-quantum keys added to them.
+
+This size can be further reduced by
+- use server domain in the link.
+- do not include onion address, as the connection happens via proxy anyway, if it's untrusted server.
+- not pinning server TLS certificate - the downside here is that while the attack that compromises TLS will not be able to substitute the link (because it's hash will not match), it will be able to intercept and to block it.
+- using shorter hash, e.g. SHA128 - reducing the collision resistance.
+
+If the server is known, the client could use it's hash and onion address, otherwise it could trust the proxy to use any existing session with the same hostname or to accept the risk of interception - given that there is no risk of substitution.
+
+With the first two of these "improvements" the link could be ~122 characters:
+
+```
+https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@/abcdefghij0123456789abcdefghij0123456789abc
+```
+
+If onion address is preserved the link will be ~184 characters (won't fit in Twitter 160 characters bio):
+
+```
+https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
+```
+
+If we implement it, the request to resolve the link would be made via proxied SMP command (to avoid the direct connection between the client and the recipient's server).
+
+Pros:
+- a bit shorter link.
+- possibility to include post-quantum keys into the full link keeping the same shortened link size.
+- possibility to include chat profile of contact or group, and preferences, for a much better connection experience, and to show this information when the link sent in the conversation (clients can resolve them automatically, without connecting - it can be resolved by the sending clients).
+- server will not have access to the link.
+
+Cons:
+- protocol complexity.
+- observers can access the link content, so for 1-time invitation we should only include permissions and not profile.
+
+Pros are a huge improvement of UX of connecting both within and from outside of the app (e.g., link can be resolved even before creating chat profile, as part of the onboarding).
+
+## Protocol
+
+To support short links, the SMP servers would provide a simple key-value store enabled by three additional commands: `WRT`, `CLR` and `READ`
+
+`WRT` command is used to store and to update values in the store. The size of the value is limited by the same size as sent messages (or, possibly, smaller - as connection information size used in confirmation messages) - the clients would use this fixed size irrespective of the content. `WRT` command will be sent with the data blob ID in the transaction entityId field, public authorization key used to authorize `WRT` and `CLR` commands (subsequent WRT commands to the existing key must use the same key), and the data blob.
+
+`CLR` command must use with the same entity ID and must be authorized by the same key.
+
+`READ` command must use the ID which hash would be equal of the ID used to create the data blob, and this ID would also be used as public authorization
+
+## Algorithm to store and to retrieve data blob.
+
+**Store data blob**
+
+- the data blob owner generates X25519 key pair: `(k, pk)`.
+- private key `pk` will be included in the short link shared with the other party (only base64url encoded key bytes, not X509 encoding).
+- `HKDF(pk)` will be used to encrypt the link data with secret_box before storing it on the server.
+- the hash of public key `sha256(k)` will be used as ID by the owner to store and to remove the data blob (`WRT` and `CLR` commands).
+
+**Retrieve data blob**
+
+- the sender uses the public key `k` derived from the private key `pk` included in the link as entity ID to retrieve data blob (the server will compute the ID used by the owner as `sha256(k)` and will be able to look it up). This provides the quality that the traffic of the parties has no shared IDs inside TLS. It also means that unlike message queue creation, the ID to retrieve the blob was never sent to the blob creator, and also is not known to the server in advance (the second part is only an observation, in itself it does not increase security, as server has access to an encrypted blob anyway).
+- note that the sender does not authorize the request to retrieve the blob, as it would not increase security unless a different key is used to authorize, and adding a key would increase link size.
+- server session keys with the sender will be `(sk, spk)`, where `sk` is public key shared with the sender during session handshake, and `spk` is the private key known only to the server.
+- this public key `k` will also be combined with server session key `spk` using `dh(k, spk)` to encrypt the response, so that there is no ciphertext in common in sent and received traffic for these blobs. Correlation ID will be used as a nonce for this encryption.
+- having received the blob, the client can now decrypt it using secret_box with `HKDF(pk)`.
+
+Using the same key as ID for the request, and also to additionally encrypt the response allows to use a single key in the link, without increasing the link size.
+
+## Threat model
+
+**Compromised SMP server**
+
+can:
+- delete link data.
+- hide link selectively from some requests.
+
+cannot:
+- undetectably replace link data.
+- access unencrypted link data, whether it was or was not accessed by the accepting party.
+- observe IP addresses of the users accessing link data.
+
+**Passive observer who observed short link**:
+
+can:
+- access original unencrypted link data
+
+cannot:
+- replace or delete the link data

rfcs/2024-07-06-ios-notifications.md

@@ -0,0 +1,18 @@
+# iOS notifications stability
+
+## Problem
+
+iOS notifications may fail to deliver for several reasons, but there are two important reasons that we could address:
+- when notification server is not subscribed to SMP server(s), the notifications can be dropped - it can happen because either notification server restarts or becuase SMP server restarted and some messages are received before notification server resubscribed. We lose approximately 3% of notifications because of this reason.
+- when user device is offline or has low power condition, Apple does not deliver notification, but puts them to storage. If while the notification is in storage a new one arrives it would overwrite the previous notification. If it was the message to the same message queue, the client will download messages anyway, up to a limit, but if the message was to another queue, it will not be delivered until the app is opened. Apple delivers about 88% of notifications that should be delivered (not accounting for uninstalled apps), the rest is replaced with the newer notifications.
+
+## Solution
+
+The first problem can be solved by preserving notifications for a limited time (say 1 hour) in case there is no subscription to notification from notification server. At the very least, they can be preserved in SMP server memory but can also be stored to a file on restart, similar to messages, and be delivered when notification server resubscribes. It is sufficient to store one notification per messaging queue.
+
+The second problem is both more damaging and more complex to solve. The solution could be to always deliver several last notifications to different queues in one packet (Apple allows up to ~4-5kb notification size, and we are sending packets of fixed size 512 bytes, so we could fit up to 8-10 of them in each notification).
+
+Every time a client receives such batch of notifications if can:
+- check if that notification was already received in the previous batch.
+- if it was received, it would be ignored, otherwise it would be processed.
+- process them one by one, started from the most recent one while the time allows.

rfcs/2024-09-05-queue-storage.md

@@ -0,0 +1,81 @@
+# Storage considerations for SMP queues
+
+See [Short invitation links](./2024-06-21-short-links.md).
+
+## Problem
+
+1) queue records are created permanently, until the clients delete them.
+
+2) clients only delete queue records based on some user action, pending connections do not expire.
+
+While part 2 should be improved in the client, indefinite storage of queue records becomes a much bigger issue if each of them would result in a permanent storage of 4-16kb blob in server memory, without server-side expiration for short invitation links.
+
+## Possible solutions
+
+1) Add some queue timestamp, e.g. queue creation date, to expire unsecured queues after say 3 weeks.
+
+The problem with this approach is that contact addresses are also unsecured queues, and they should not be expired.
+
+We could set really large expiration time, and require that clients "update" the unsecured queues they need at least every 1-2 years, but it would not solve the problem of storing a large number of blobs in the server memory for unused/abandoned 1-time invitations.
+
+2) Do not store blobs in memory / append-only log, and instead use something like RocksDB. While it may be a correct long term solution, it may be not expedient enough at the current POC stage for this feature. Also, the lack of expiration is wrong in any case and would indefinitely grow server storage.
+
+3) Add flag allowing the server to differentiate permanent queues used as contact addresses, also using different blob sizes for them. In this case, messaging queues will be expired if not secured after 3 weeks, and contact address queues would be expired if not "updated" by the owner within 2 years.
+
+Probably all three solutions need to be used, to avoid creating a non-expiring blob storage in memory, as in case too many of such blobs are created it would not be possible to differentiate between real users and resource exhaustion attacks, and unlike with messages, they won't be expiring too.
+
+Servers already can differentiate messaging queues and contact address queues, if they want to:
+- with the old 4-message handshake, the confirmation message on a normal queue was different, and also KEY command was eventually used.
+- with the fast 2-message handshake, while the confirmation message has the same syntax, and the differences are inside encrypted envelope, the client still uses SKEY command.
+- in both cases, the usual messaging queues are secured, and contact addresses are not, so this difference is visible in the storage as well (although it is not easy to differentiate between abandoned 1-time invitations and contact addresses).
+
+Differentiating these queues can also allow different message retention times - e.g., the queues for contact addresses could have bigger size, but have lower message retention time.
+
+## Proposed solution
+
+1. Add queue updated_at date into queue records. While it adds some metadata, it seems necessary to manage retention and quality of service. It will not include exact time, only date, and the time of creation will be replaced by the time of any update - queue secured, a message is sent, or queue owner subscribes to the queue. To avoid the need to update store log on every message this information can be appended to store log on server termination. Or given that only one update per day is needed it may be ok to make these updates as they happen (temporarily making the sequence and time of these events available in storage).
+
+2. Add flag to indicate the queue usage - messaging queue or queue for contact address connection requests. This would result in different queue size and different retention policy for queue and its messages. We already have "sender can secure flag" which is, effectively, this flag - contact address queues are never secured. So this does not increase stored metadata in any way.
+
+## Possible changes to short links
+
+This is a design considerations and a concept, not a design yet.
+
+Instead of implementing a generic blob storage that can be used as an attack vector, and adds additional failure point (another server storing blob that is necessary to connect to the queue on the current server), but instead adds an extended queue information blobs, most of which could be dropped without the loss of connectivity, so that the attack can be mitigated by deleting these blobs without users losing the ability to connect, as long as the queue and minimal extended information is retained.
+
+So, to make the connection there need to be these elements:
+
+- queue server and queue ID - mandatory part, that can be included in short link
+- SMP key - mandatory part for all queues. We are considering initializing ratchets earlier for contact addresses, and include ratchet keys and pre-keys into queue data as well, but it is out of scope here.
+- Ratchet keys - mandatory part for 1-time invitation that won't fit in short link.
+- PQ key - optional part that can be stored with addresses if ratchet keys are added and with 1-time invitations.
+- App blobs - chat preferences for 1-time invitation links and profile information for contact addresses.
+
+So rather that storing one blob with a large address inside it, not associated with the queue, increasing probability of failure and reducing our ability to mitigate resource exhaustion, we could store extended blobs associated with the queues.
+
+Also, we need the address shared with the sender (party accepting the connection) to be short. We could use a similar approach that was proposed for data blobs, using a single random seed per queues to derive multiple keys and IDs from it. For example:
+
+1. The queue owner:
+  - generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now sent in NEW command.
+  - generates queue recipient ID (this ID can still be server-generated).
+  - generates X25519 key pair `(k, pk)` to use with the accepting party.
+  - derives from `k`:
+    - sender ID.
+    - symmetric key for authenticated encryption of blobs.
+  - `k` will be used as short link.
+2. All other data from the invitation can be included in queue creation request and be associated with the queue as 1-3 blobs with different priority:
+  - ratchet keys - it will have a small size, so only this blob cannot be removed, while other blobs can be removed in case of resource exhaustion.
+  - PQ keys - optional blob.
+  - conversation preferences and profile - can be removed depending on creation time, e.g. all new blobs can be removed.
+
+The algorithm used to derive key and ID from `k` needs to be cryptographically secure, e.g. it could be some KDF or ChaCha DRG initialized with `k` as seed, TBC.
+
+So, coupling blob storage with messaging queues has these pros/cons:
+
+Cons:
+- no additional layer of privacy - the server used for connection is visible in the link, even after the blobs are removed from the server.
+
+Pros:
+- no additional point of failure in the connection process - the same server will be used to retrieve necessary blobs as for connection.
+- queue blobs of messaging blobs will be automatically removed once the queue is secured or expired, without additional request from the recipient - reducing the storage and the time these blobs are available.
+- queue blobs for contact addresses will be structured and some of the large blobs can be removed in case of resource exhaustion attack (and recreated by the client if needed), with the only downside that PQ handshake will be postponed (which is the case now) and profile will not be available at a point of connection.

rfcs/2024-09-09-smp-blobs.md

@@ -0,0 +1,80 @@
+# Blob extensions for SMP queues
+
+Evolution of the design for short links, see [here](./2024-06-21-short-links.md) and [here](./2024-09-05-queue-storage.md).
+
+## Problems
+
+Allow storing extended information with SMP queues to improve UX and security of making connections:
+- short invitation links and contact addresses.
+- PQ encryption from the first message.
+- present user profile with chat preferences and welcome message when the public address link is scanned.
+
+## Design
+
+1. Queue creation/update date is already added to server persistence, allowing to expire queues and blobs, depending on their usage.
+2. Add "queue type" metadata to NEW command to indicate whether messaging queue is used as public address or as messaging queue (see previous docs on why it doesn't change threat model). While at the moment it would match sndSecure flag there may be future scenarios when they diverge. Initially only "invitation" and "contact" types will be supported.
+3. Prohibit sndSecure flag for "contact" queues, prohibit securing contact queues.
+4. Add "queue blobs" to NEW command:
+  - blob0: ratchetKeys up to N0 bytes - priority 0, can't be removed by the server, only in "invitation"
+  - blob1: PQ key up to N1 bytes - priority 1, can be removed by the server, only used in "invitation"
+  - blob2: Application data up to N2 bytes - priority 2, can be removed by the server.
+5. Add linkId to NEW command
+6. linkId and blobs will be removed when queue is secured.
+7. Add recipient command to remove/upsert blob2 for contact queues.
+8. Add sender command to retrieve blobs.
+
+## Protocol
+
+### Creating a queue:
+
+The queue owner:
+- generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now. `sk` and `dhk` will be sent in NEW command.
+- generates X25519 key pair `(k, pk)` to use with the accepting party to encrypt queue messages.
+- derives from `k` using HKDF:
+- symmetric key `bk` for authenticated encryption of blobs.
+- `linkId`, will be sent in NEW command.
+- `k` will be used as short link.
+- sends NEW command.
+
+NEW command syntax:
+
+```abnf
+create = %s"NEW " linkId queueType recipientAuthPublicKey recipientDhPublicKey
+                  basicAuth subscribe sndSecure [ "0" blob0 ] [ "1" blob1 ] [ "2" blob2 ] 
+queueType = %s"I" / %s "C" ; new parameter
+linkId = length *OCTET ; new parameter,
+                        ; can be empty in which case blobs won't be allowed
+blob0 = word16 *OCTET ; new parameter, encrypted ratchet keys,
+                      ; including nonce and auth tag
+blob1 = word16 *OCTET ; new parameter, encrypted PQ key
+blob2 = word16 *OCTET ; new parameter, encrypted application data
+```
+
+SET - command to update queue blobs (recipientId is used as entity ID):
+
+```abnf
+set = %s"SET " linkId [ "2" blob2 ] ; passing empty blob removes it
+linkId ; updated (or the same) linkId, can be empty to remove blobs
+        ; allows to change the address without removing the queue / changing blobs
+        ; (e.g., to avoid losing the messages).
+```
+
+### Sending messages to the queue
+
+GET - command to get queue blobs (linkId is used as entity ID):
+
+```abnf
+get = %s"GET"
+```
+
+Response to GET:
+
+```abnf
+blobs = %s"BLOB" senderId [ "0" blob0 ] [ "1" blob1 ] [ "2" blob2 ]
+```
+
+As blobs are retrieved using a separate linkId, once blobs are removed it will be impossible to find senderId from short link - it is a threat model improvement. Once server storage is compacted, it will be impossible to find queue related to the link even with the access to server data (unless server preserves the data).
+
+### Possible privacy improvement
+
+We could only allow unauthorized GET and authorized SET commands for long-term "contact" queues, and return BLOB in response to SKEY (or require that GET is authorized) - so that only the person who secures the queue will get access to data blobs. This way it ensures that the parties transmitting the invitation links cannot retrieve their content without the sender noticing it.

rfcs/2024-09-10-private-rendezvous.md

@@ -0,0 +1,26 @@
+# Private rendezvous protocol
+
+## Problem
+
+Our current handshake protocol is open to this attack: whoever observes the link exchange, knows on which server connection is being made, and if the traffic on this server is observed, then it can confirm communication between parties. Further, even with the [last proposal](./2024-09-09-smp-blobs.md#possible-privacy-improvement), having real-time access to the server data allows to establish the exact messaging queue that is used to send messages.
+
+## Solution
+
+We could make the initial link exchange more private by making it harder for any observer to discover which server will be used for messaging by hiding this information from the server that hosts the initial link.
+
+Preliminary, the protocol could be the following:
+
+1. Connection initiator stores 224-256 bytes of encrypted connection link on a rendezvous server (link contains server host and linkId on another messaging server, not a rendezvous one).
+
+2. Rendezvous server adds these links to buckets, up to 64 links per bucket. Bucket ID is the timestamp when the bucket was created + a sequential bucket number, in case more than one bucket is created per second.
+
+3. The server responds to the link creator with a bucket ID where this link was added. That bucket ID is its timestamp + a number prevents server "fingerprinting" clients and using say one bucket for each client. If timestamp is different or a bucket number within this timestamp is too large, the client can refuse to use it, depending on the client settings.
+
+4. The initiating party will pass to the accepting party the rendezvous server host, the hash of this bucket ID (bucket link) and the passphrase to derive the key from. The initiating party has an option to pass a link and passphrase via two channels - in which case the link will only contain the bucket ID.
+
+5. The accepting party would then request the bucket via its ID hash (the server would store hashes to be able to look up - hash is used to prevent showing time in the link) and attempt to decrypt all contained links using the provided key.
+The accepting party then will continue the connection via the decrypted link.
+
+This obviously does not protect accepting party from the initiating party, if it can choose rendezvous server it controls. It also does not protect from the malicious rendezvous server that would collaborate with link observers. I think reunion doesn’t protect from it too.
+
+But it does protect connection from whoever observes the link, particularly if this link only contains the bucket and the key is passed separately, via some other channel.

scripts/main/simplex-servers-stopscript

@@ -1,30 +1,174 @@
 #!/usr/bin/env sh
 set -eu
 
-path_conf_var="/var/opt"
-path_conf_smp="$path_conf_var/simplex"
-path_conf_xftp="$path_conf_var/simplex-xftp"
-path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
-path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
+# Common
+# ------
 date="$(date -u '+%Y-%m-%dT%H:%M:%S')"
 
-backup_smp() {
- if [ -e "$path_conf_storelog_smp" ]; then
-  cp "$path_conf_storelog_smp" "${path_conf_storelog_smp}.${date:-date-failed}"
- fi
+GRN='\033[0;32m'
+YLW='\033[1;33m'
+BLU='\033[1;34m'
+RED='\033[0;31m'
+NC='\033[0m'
+
+path_conf_var="/var/opt"
+
+smp_variables() {
+	path_conf_smp="$path_conf_var/simplex"
+	path_conf_smp_archive="$path_conf_smp/backups"
+	path_conf_smp_archive_storelog="$path_conf_smp_archive/queues"
+	path_conf_smp_archive_stats="$path_conf_smp_archive/stats"
+	path_conf_smp_archive_messages="$path_conf_smp_archive/messages"
+	path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
+	path_conf_storelog_smp_out="$path_conf_smp_archive_storelog/smp-server-store.log.${date:-date-failed}"
+
+	path_conf_stats_smp="$path_conf_smp/smp-server-stats.log"
+	path_conf_stats_smp_out="$path_conf_smp_archive_stats/smp-server-stats.log.${date:-date-failed}"
+
+	path_conf_messages_smp="$path_conf_smp/smp-server-messages.log"
+	path_conf_messages_smp_out="$path_conf_smp_archive_messages/smp-server-messages.log.${date:-date-failed}"
 }
 
-backup_xftp() {
- if [ -e "$path_conf_storelog_xftp" ]; then
-  cp "$path_conf_storelog_xftp" "${path_conf_storelog_xftp}.${date:-date-failed}"
- fi
+xftp_variables() {
+	path_conf_xftp="$path_conf_var/simplex-xftp"
+	path_conf_xftp_archive="$path_conf_xftp/backups"
+
+	path_conf_xftp_archive_storelog="$path_conf_xftp_archive/queues"
+	path_conf_xftp_archive_stats="$path_conf_xftp_archive/stats"
+
+	path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
+	path_conf_storelog_xftp_out="$path_conf_xftp_archive_storelog/file-server-store.log.${date:-date-failed}"
+
+	path_conf_stats_xftp="$path_conf_xftp/file-server-stats.log"
+	path_conf_stats_xftp_out="$path_conf_xftp_archive_stats/file-server-stats.log.${date:-date-failed}"
 }
 
-if [ "$1" = 'smp-server' ]; then
- backup_smp
-elif [ "$1" = 'xftp-server' ]; then
- backup_xftp
-else
- backup_smp
- backup_xftp
-fi
+checks() {
+	result=${SERVICE_RESULT:-exit-code}
+	status=${EXIT_STATUS:-TERM}
+
+	case "$result" in
+		success)
+			case "$status" in
+				TERM)
+					printf "${RED}Refusing to backup files with failed service state${NC}\n"
+					exit 1
+					;;
+				*)
+					:
+					;;
+			esac
+			;;
+		*)
+			printf "${RED}Refusing to backup files with failed service state${NC}\n"
+			exit 1
+			;;
+	esac
+}
+
+smp_check() {
+	if [ ! -d "$path_conf_smp_archive_storelog" ]; then
+		mkdir -p "$path_conf_smp_archive_storelog"
+	fi
+	if [ ! -d "$path_conf_smp_archive_messages" ]; then
+		mkdir -p "$path_conf_smp_archive_messages"
+	fi
+	if [ ! -d "$path_conf_smp_archive_stats" ]; then
+		mkdir -p "$path_conf_smp_archive_stats"
+	fi
+}
+
+xftp_check() {
+	if [ ! -d "$path_conf_xftp_archive_storelog" ]; then
+		mkdir -p "$path_conf_xftp_archive_storelog"
+	fi
+	if [ ! -d "$path_conf_xftp_archive_stats" ]; then
+		mkdir -p "$path_conf_xftp_archive_stats"
+	fi
+}
+
+backup() {
+	file="$1"
+	out="$2"
+	file_type="$3"
+
+	if [ -e "$file" ]; then
+		if cp "$file" "$out"; then
+			printf "${YLW}${file_type}${NC} ${GRN}backup successful:${NC} ${BLU}%s${NC}\n" "${out}"
+		else
+			printf "${YLW}${file_type}${NC} ${RED}backup failed!${NC}\n"
+		fi
+	fi
+
+	unset file out file_type
+}
+
+cleanup() {
+	directory="$1"
+	
+	file_type="$2"
+	
+	files_date=$(find "$directory" -type f -exec stat --format="%y" {} + | awk '{print $1}' | sort -nr | uniq | awk 'NR==2')
+	
+	if [ -n "$files_date" ]; then
+		files=$(find "$directory" -type f -not -newermt "$files_date" -printf "%T@ %Tc %p\n" | sort -n | awk '{print $NF}')
+
+		if [ -n "$files" ]; then
+			printf '%s' "$files" | xargs rm -f
+			printf "${YLW}Old ${file_type} files${NC}${GRN} has been deleted:${NC}\n"
+			files_colored=$(printf '%s' "$files" | awk '{print "\033[1;34m"$0"\033[0m"}')
+			printf "${files_colored}\n"
+		fi
+	fi
+
+	unset directory file_type files_date files
+}
+
+smp_backup() {
+	backup "$path_conf_storelog_smp" "$path_conf_storelog_smp_out" 'Storelog'
+	backup "$path_conf_messages_smp" "$path_conf_messages_smp_out" 'Messages'
+	backup "$path_conf_stats_smp" "$path_conf_stats_smp_out" 'Stats'
+}
+
+smp_cleanup() {
+	cleanup "$path_conf_smp_archive_storelog" 'storelog'
+	cleanup "$path_conf_smp_archive_stats" 'stats'
+	cleanup "$path_conf_smp_archive_messages" 'messages'
+}
+
+xftp_backup() {
+	backup "$path_conf_storelog_xftp" "$path_conf_storelog_xftp_out" 'Storelog'
+	backup "$path_conf_stats_xftp" "$path_conf_stats_xftp_out" 'Stats'
+}
+
+xftp_cleanup() {
+	cleanup "$path_conf_xftp_archive_storelog" 'storelog'
+	cleanup "$path_conf_xftp_archive_stats" 'stats'
+}
+
+main() {
+	type="${1:-}"
+  
+	checks
+
+	case "$type" in
+		smp-server)
+			smp_variables
+			smp_check
+			smp_backup
+			smp_cleanup
+			;;
+		xftp-server)
+			xftp_variables
+			xftp_check
+			xftp_backup
+			xftp_cleanup
+			;;
+		*)
+			printf "${YLW}Unknown server type.${NC}\n"
+			exit 1
+			;;
+	esac 
+}
+
+main "$@"

scripts/main/simplex-servers-uninstall

@@ -13,11 +13,15 @@ fi
 printf "${RED}This action will permanently remove all configs, directories, binaries from Installation Script. Please backup any relevant configs if they are needed.${NC}\n\nPress ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
 read ans
 
-systemctl stop smp-server
-systemctl stop xftp-server
+systemctl disable --now smp-server 2>/dev/null || true
+systemctl revert smp-server 2>/dev/null || true
+systemctl disable --now xftp-server 2>/dev/null || true
+systemctl revert xftp-server 2>/dev/null || true
+systemctl daemon-reload 2>/dev/null || true
 
-rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall
+rm -rf /var/opt/simplex /etc/opt/simplex /etc/opt/simplex-info /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall /usr/local/bin/simplex-servers-stopscript
 
-userdel smp && userdel xftp
+userdel smp 2>/dev/null || true
+userdel xftp 2>/dev/null || true
 
 printf "Uninstallation is complete! Thanks for trying out SimpleX!\n"

scripts/main/simplex-servers-update

@@ -3,8 +3,6 @@ set -eu
 
 # Links to scripts/configs
 bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
-bin_smp="$bin/smp-server-ubuntu-20_04-x86-64"
-bin_xftp="$bin/xftp-server-ubuntu-20_04-x86-64"
 
 scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
 scripts_systemd_smp="$scripts/smp-server.service"
@@ -33,6 +31,9 @@ path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
 path_tmp_systemd_smp="$path_tmp_bin/smp-server.service"
 path_tmp_systemd_xftp="$path_tmp_bin/xftp-server.service"
 
+path_conf_etc='/etc/opt'
+path_conf_info='/etc/opt/simplex-info'
+
 GRN='\033[0;32m'
 BLU='\033[1;36m'
 YLW='\033[1;33m'
@@ -40,8 +41,40 @@ RED='\033[0;31m'
 NC='\033[0m'
 
 # Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version
-local_version="$($path_bin_smp -v | awk '{print $3}')"
-remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
+
+os_test() {
+ . /etc/os-release
+
+ case "$VERSION_ID" in
+  20.04|22.04) : ;;
+  24.04) VERSION_ID='22.04' ;;
+  *) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
+ esac
+
+ version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
+ arch="$(uname -p)"
+
+ case "$arch" in
+  x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
+  *)  printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
+ esac
+
+ bin_smp="$bin/smp-server-ubuntu-${version}-${arch}"
+ bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}"
+}
+
+installed_test() {
+  set +u
+  for i in $path_conf_etc/*; do
+    if [ -d "$i" ]; then
+      case "$i" in
+        *simplex) apps="smp $apps" ;;
+        *simplex-xftp) apps="xftp $apps" ;;
+      esac
+    fi
+  done
+  set -u
+}
 
 update_scripts() {
   curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
@@ -56,6 +89,7 @@ update_scripts() {
     mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
     printf "${GRN}Done!${NC}\n"
   fi
+
   if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
     printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
     rm "$path_tmp_bin_stopscript"
@@ -64,6 +98,7 @@ update_scripts() {
     mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
     printf "${GRN}Done!${NC}\n"
   fi
+
   if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
     printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
     rm "$path_tmp_bin_update"
@@ -71,75 +106,84 @@ update_scripts() {
     printf -- "- Updating update script..."
     mv "$path_tmp_bin_update" "$path_bin_update"
     printf "${GRN}Done!${NC}\n"
-    printf "Re-executing Update script with latest updates..."
+    printf -- "- Re-executing Update script with latest updates..."
     exec sh "$path_bin_update" "continue"
   fi
 }
 
 update_systemd() {
-  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_tmp_systemd_smp"
-  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_tmp_systemd_xftp"
+  service="${1}-server"
+  eval "scripts_systemd=\$scripts_systemd_${1}"
+  eval "path_systemd=\$path_systemd_${1}"
+  eval "path_tmp_systemd=\$path_tmp_systemd_${1}"
+   
+  curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_tmp_systemd"
 
-  if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null 2>&1; then
-    printf -- "- ${YLW}smp-server service is up-to-date${NC}.\n"
-    rm "$path_tmp_systemd_smp"
+  if diff -q "$path_systemd" "$path_tmp_systemd" > /dev/null 2>&1; then
+    printf -- "- ${YLW}%s service is up-to-date${NC}.\n" "$service"
+    rm "$path_tmp_systemd"
   else
-    printf -- "- Updating smp-server service..."
-    mv "$path_tmp_systemd_smp" "$path_systemd_smp"
-    systemctl daemon-reload
-    printf "${GRN}Done!${NC}\n"
-  fi
-  if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null 2>&1; then
-    printf -- "- ${YLW}xftp-server service is up-to-date${NC}.\n"
-    rm "$path_tmp_systemd_xftp"
-  else
-    printf -- "- Updating xftp-server service..."
-    mv "$path_tmp_systemd_xftp" "$path_systemd_xftp"
+    printf -- "- Updating %s service..." "$service"
+    mv "$path_tmp_systemd" "$path_systemd"
     systemctl daemon-reload
     printf "${GRN}Done!${NC}\n"
   fi
+
+  unset service scripts_systemd path_systemd path_tmp_systemd
 }
 
 update_bins() {
-  if [ "$local_version" != "$remote_version" ]; then
-    if systemctl is-active --quiet smp-server; then
-      printf -- "- Stopping smp-server service..."
-      systemctl stop smp-server
-      printf "${GRN}Done!${NC}\n"
+  service="${1}-server"
+  eval "bin=\$bin_${1}"
+  eval "path_bin=\$path_bin_${1}"
 
-      printf -- "- Updating smp-server bin to %s..." "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
-      printf "${GRN}Done!${NC}\n"
-      
-      printf -- "- Starting smp-server service..."
-      systemctl start smp-server
-      printf "${GRN}Done!${NC}\n"
-    else
-      printf -- "- Updating smp-server bin..."
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
-      printf "${GRN}Done!${NC}\n"
+  remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
+
+  set_ver() {
+    local_version='unset'
+    sed -i -- "s/local_version_${1}=.*/local_version_${1}='${remote_version}'/" "$path_conf_info/release"
+  }
+
+  if [ -f "$path_conf_info/release" ]; then
+    . "$path_conf_info/release" 2>/dev/null
+
+    set +u
+    eval "local_version=\$local_version_${1}"
+    set -u
+
+    if [ -z "${local_version}" ]; then
+            set_ver "$1"
     fi
+  else
+    printf 'local_version_xftp=\nlocal_version_smp=\n' > "$path_conf_info/release"
+    set_ver "$1"
+  fi
 
-    if systemctl is-active --quiet xftp-server; then
-      printf -- "- Stopping xftp-server service..."
-      systemctl stop xftp-server
+  if [ "$local_version" != "$remote_version" ]; then
+    if systemctl is-active --quiet "$service"; then
+      printf -- "- Stopping %s service..." "$service"
+      systemctl stop "$service"
       printf "${GRN}Done!${NC}\n"
 
-      printf -- "- Updating xftp-server bin to %s..." "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
+      printf -- "- Updating %s to %s..." "$service" "$remote_version"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
       printf "${GRN}Done!${NC}\n"
       
-      printf -- "- Starting xftp-server service..."
-      systemctl start xftp-server
+      printf -- "- Starting %s service..." "$service"
+      systemctl start "$service"
       printf "${GRN}Done!${NC}\n"
     else
-      printf -- "- Updating xftp-server bin..."
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
+      printf -- "- Updating %s to %s..." "$service" "$remote_version"
+      curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
       printf "${GRN}Done!${NC}\n"
     fi
   else
-    printf -- "- ${YLW}smp-server and xftp-server binaries is up-to-date${NC}.\n"
+    printf -- "- ${YLW}%s is up-to-date${NC}.\n" "$service"
   fi
+
+  set_ver "$1"
+
+  unset service bin path_bin local_version
 }
 
 checks() {
@@ -147,6 +191,11 @@ checks() {
     printf "This script is intended to be run with root privileges. Please re-run script using sudo.\n"
     exit 1
   fi
+
+  os_test
+  installed_test
+
+  mkdir -p $path_conf_info
 }
 
 main() {
@@ -163,10 +212,14 @@ main() {
   fi
 
   printf "Updating systemd services...\n"
-  update_systemd
+  for i in $apps; do
+    update_systemd "$i"
+  done
   
-  printf "Updating simplex server binaries...\n"
-  update_bins
+  printf "Updating simplex servers...\n"
+  for i in $apps; do
+    update_bins "$i"
+  done
 
   rm -rf "$path_tmp_bin"
 }

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        6.0.0.8
+version:        6.1.0.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -236,6 +236,7 @@ library
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -258,7 +259,7 @@ library
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.7.0 && <1.8
+    , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -310,6 +311,7 @@ executable ntf-server
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -333,7 +335,7 @@ executable ntf-server
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.7.0 && <1.8
+    , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -389,6 +391,7 @@ executable smp-server
     , directory ==1.3.*
     , file-embed
     , filepath ==1.4.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -412,7 +415,7 @@ executable smp-server
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.7.0 && <1.8
+    , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -467,6 +470,7 @@ executable xftp
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -490,7 +494,7 @@ executable xftp
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.7.0 && <1.8
+    , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -542,6 +546,7 @@ executable xftp-server
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -565,7 +570,7 @@ executable xftp-server
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.7.0 && <1.8
+    , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -605,6 +610,7 @@ test-suite simplexmq-test
       CoreTests.CryptoTests
       CoreTests.EncodingTests
       CoreTests.RetryIntervalTests
+      CoreTests.SOCKSSettings
       CoreTests.TRcvQueuesTests
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
@@ -653,6 +659,7 @@ test-suite simplexmq-test
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hashable ==1.4.*
     , hourglass ==0.2.*
     , hspec ==2.11.*
     , hspec-core ==2.11.*
@@ -681,7 +688,7 @@ test-suite simplexmq-test
     , time ==1.12.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.7.0 && <1.8
+    , tls >=1.9.0 && <1.10
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*

src/Simplex/FileTransfer/Agent.hs

@@ -45,7 +45,7 @@ import Data.List (foldl', partition, sortOn)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
@@ -74,7 +74,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (strDecode, strEncode)
-import Simplex.Messaging.Protocol (EntityId, ProtocolServer, ProtocolType (..), XFTPServer)
+import Simplex.Messaging.Protocol (ProtocolServer, ProtocolType (..), XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM)
 import System.FilePath (takeFileName, (</>))
@@ -190,8 +190,9 @@ runXFTPRcvWorker c srv Worker {doWork} = do
     runXFTPOperation :: AgentConfig -> AM ()
     runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} =
       withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case
-        (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas")
-        (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do
+        (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _, redirectEntityId_) ->
+          rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) (INTERNAL "chunk has no replicas")
+        (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays, redirectEntityId_) -> do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitWhileSuspended c
@@ -202,7 +203,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
-                when (serverHostError e) $ notify c rcvFileEntityId $ RFWARN e
+                when (serverHostError e) $ notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFWARN e)
                 liftIO $ closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
               liftIO $ assertAgentForeground c
@@ -211,7 +212,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
               atomically . incXFTPServerStat c userId srv $ case e of
                 XFTP _ XFTP.AUTH -> downloadAuthErrs
                 _ -> downloadErrs
-              rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e
+              rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) e
     downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM ()
     downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do
       unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED
@@ -262,11 +263,11 @@ retryOnError name loop done e = do
     then loop
     else done
 
-rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
-rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do
+rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
+rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do
   lift $ forM_ tmpPath (removePath <=< toFSFilePath)
   withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
-  notify c rcvFileEntityId $ RFERR err
+  notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err)
 
 runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM ()
 runXFTPRcvLocalWorker c Worker {doWork} = do
@@ -279,8 +280,8 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
     runXFTPOperation :: AgentConfig -> AM ()
     runXFTPOperation AgentConfig {rcvFilesTTL} =
       withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
-        \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
-          decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath
+        \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath, redirect} ->
+          decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
     decryptFile :: RcvFile -> AM ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
       let CryptoFile savePath cfArgs = saveFile
@@ -346,7 +347,7 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
     batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> AM' [Either AgentErrorType a]
     batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles
 
-notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m ()
+notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
 
 xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId

src/Simplex/FileTransfer/Client.hs

@@ -22,6 +22,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.Time.Clock (UTCTime)
 import Data.Word (Word32)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
@@ -36,8 +37,8 @@ import Simplex.Messaging.Client
     TransportSession,
     chooseTransportHost,
     defaultNetworkConfig,
-    proxyUsername,
     transportClientConfig,
+    clientSocksCredentials,
     unexpectedResponse,
   )
 import qualified Simplex.Messaging.Crypto as C
@@ -50,6 +51,7 @@ import Simplex.Messaging.Protocol
     ProtocolServer (..),
     RecipientId,
     SenderId,
+    pattern NoEntity,
   )
 import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
 import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
@@ -97,9 +99,9 @@ defaultXFTPClientConfig =
       clientALPN = Just supportedXFTPhandshakes
     }
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
-  let username = proxyUsername transportSession
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
+  let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
   let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN}
@@ -107,7 +109,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
       clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
-  http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
+  http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client socksCreds useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
   let HTTP2Client {sessionId, sessionALPN} = http2Client
       v = VersionXFTP 1
       thServerVRange = versionToRange v
@@ -222,7 +224,7 @@ createXFTPChunk ::
   Maybe BasicAuth ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
 createXFTPChunk c spKey file rcps auth_ =
-  sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case
+  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case
     (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
     (r, _) -> throwE $ unexpectedResponse r
 
@@ -278,7 +280,7 @@ pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
 pingXFTP c@XFTPClient {thParams} = do
   t <-
     liftEither . first PCETransportError $
-      xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING)
+      xftpEncodeTransmission thParams ("", NoEntity, FileCmd SFRecipient PING)
   (r, _) <- sendXFTPTransmission c t Nothing
   case r of
     FRPong -> pure ()

src/Simplex/FileTransfer/Client/Agent.hs

@@ -16,6 +16,7 @@ import Data.Bifunctor (first)
 import qualified Data.ByteString.Char8 as B
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8)
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import Simplex.FileTransfer.Client
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
@@ -30,6 +31,7 @@ type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
 
 data XFTPClientAgent = XFTPClientAgent
   { xftpClients :: TMap XFTPServer XFTPClientVar,
+    startedAt :: UTCTime,
     config :: XFTPClientAgentConfig
   }
 
@@ -56,19 +58,20 @@ data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
 newXFTPAgent :: XFTPClientAgentConfig -> IO XFTPClientAgent
 newXFTPAgent config = do
   xftpClients <- TM.emptyIO
-  pure XFTPClientAgent {xftpClients, config}
+  startedAt <- getCurrentTime
+  pure XFTPClientAgent {xftpClients, startedAt, config}
 
 type ME a = ExceptT XFTPClientAgentError IO a
 
 getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
-getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
+getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
   atomically getClientVar >>= either newXFTPClient waitForXFTPClient
   where
     connectClient :: ME XFTPClient
     connectClient =
       ExceptT $
         first (XFTPClientAgentError srv)
-          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
+          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) startedAt clientDisconnected
 
     clientDisconnected :: XFTPClient -> IO ()
     clientDisconnected _ = do

src/Simplex/FileTransfer/Client/Main.hs

@@ -44,7 +44,7 @@ import Data.List (foldl', sortOn)
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import Data.Word (Word32)

src/Simplex/FileTransfer/Description.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -53,7 +55,7 @@ import Data.List (foldl', sortOn)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
 import Data.String
 import Data.Text (Text)
@@ -139,12 +141,9 @@ data FileChunkReplica = FileChunkReplica
   }
   deriving (Eq, Show)
 
-newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: ByteString}
+newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: XFTPFileId}
   deriving (Eq, Show)
-
-instance StrEncoding ChunkReplicaId where
-  strEncode (ChunkReplicaId fid) = strEncode fid
-  strP = ChunkReplicaId <$> strP
+  deriving newtype (StrEncoding)
 
 instance FromJSON ChunkReplicaId where
   parseJSON = strParseJSON "ChunkReplicaId"
@@ -153,10 +152,6 @@ instance ToJSON ChunkReplicaId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-instance FromField ChunkReplicaId where fromField f = ChunkReplicaId <$> fromField f
-
-instance ToField ChunkReplicaId where toField (ChunkReplicaId s) = toField s
-
 data YAMLFileDescription = YAMLFileDescription
   { party :: FileParty,
     size :: String,

src/Simplex/FileTransfer/Protocol.hs

@@ -41,6 +41,7 @@ import Simplex.Messaging.Protocol
     ProtocolType (..),
     RcvPublicAuthKey,
     RcvPublicDhKey,
+    EntityId (..),
     RecipientId,
     SenderId,
     SentRawTransmission,
@@ -170,7 +171,7 @@ data FileInfo = FileInfo
   }
   deriving (Show)
 
-type XFTPFileId = ByteString
+type XFTPFileId = EntityId
 
 instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
@@ -191,7 +192,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
   fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (auth, _, fileId, _) cmd = case cmd of
+  checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of
     -- FNEW must not have signature and chunk ID
     FNEW {}
       | isNothing auth -> Left $ CMD NO_AUTH
@@ -301,7 +302,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (_, _, entId, _) cmd = case cmd of
+  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
     FRSndIds {} -> noEntity
     -- ERR response does not always have entity ID
     FRErr _ -> Right cmd

src/Simplex/FileTransfer/Server.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -32,11 +33,11 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Data.X509 as X
 import GHC.IO.Handle (hSetNewlineMode)
+import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
@@ -52,9 +53,10 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
+import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -63,7 +65,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
+import Simplex.Messaging.Transport.Server (runLocalTCPServer, tlsServerCredentials)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Exit (exitFailure)
@@ -207,17 +209,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
           hSetBuffering h LineBuffering
           ts <- getCurrentTime
-          fromTime' <- atomically $ swapTVar fromTime ts
-          filesCreated' <- atomically $ swapTVar filesCreated 0
-          fileRecipients' <- atomically $ swapTVar fileRecipients 0
-          filesUploaded' <- atomically $ swapTVar filesUploaded 0
-          filesExpired' <- atomically $ swapTVar filesExpired 0
-          filesDeleted' <- atomically $ swapTVar filesDeleted 0
-          files <- atomically $ periodStatCounts filesDownloaded ts
-          fileDownloads' <- atomically $ swapTVar fileDownloads 0
-          fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0
-          filesCount' <- readTVarIO filesCount
-          filesSize' <- readTVarIO filesSize
+          fromTime' <- atomicSwapIORef fromTime ts
+          filesCreated' <- atomicSwapIORef filesCreated 0
+          fileRecipients' <- atomicSwapIORef fileRecipients 0
+          filesUploaded' <- atomicSwapIORef filesUploaded 0
+          filesExpired' <- atomicSwapIORef filesExpired 0
+          filesDeleted' <- atomicSwapIORef filesDeleted 0
+          files <- liftIO $ periodStatCounts filesDownloaded ts
+          fileDownloads' <- atomicSwapIORef fileDownloads 0
+          fileDownloadAcks' <- atomicSwapIORef fileDownloadAcks 0
+          filesCount' <- readIORef filesCount
+          filesSize' <- readIORef filesSize
           hPutStrLn h $
             intercalate
               ","
@@ -247,7 +249,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       u <- askUnliftIO
       liftIO $ do
         labelMyThread "control port server"
-        runTCPServer cpStarted port $ runCPClient u
+        runLocalTCPServer cpStarted port $ runCPClient u
       where
         runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
         runCPClient u sock = do
@@ -309,7 +311,7 @@ data ServerFile = ServerFile
 
 processRequest :: XFTPTransportRequest -> M ()
 processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
-  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
+  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
   | otherwise = do
       case xftpDecodeTransmission thParams bodyHead of
         Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
@@ -322,7 +324,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
             Left e -> send (FRErr e) Nothing
           where
             send resp = sendXFTPResponse (corrId, fId, resp)
-        Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
+        Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
   where
     sendXFTPResponse (corrId, fId, resp) serverFile_ = do
       let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
@@ -397,7 +399,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       r <- runExceptT $ do
         sizes <- asks $ allowedChunkSizes . config
         unless (size file `elem` sizes) $ throwE SIZE
-        ts <- liftIO getSystemTime
+        ts <- liftIO getFileTime
         -- TODO validate body empty
         sId <- ExceptT $ addFileRetry st file 3 ts
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
@@ -405,12 +407,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
           logAddFile sl sId file ts
           logAddRecipients sl sId rcps
         stats <- asks serverStats
-        atomically $ modifyTVar' (filesCreated stats) (+ 1)
-        atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
+        lift $ incFileStat filesCreated
+        liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRSndIds sId rIds
       pure $ either FRErr id r
-    addFileRetry :: FileStore -> FileInfo -> Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
+    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
     addFileRetry st file n ts =
       retryAdd n $ \sId -> runExceptT $ do
         ExceptT $ addFile st sId file ts
@@ -435,7 +437,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         lift $ withFileLog $ \sl -> logAddRecipients sl sId rcps
         stats <- asks serverStats
-        atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
+        liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRRcvIds rIds
       pure $ either FRErr id r
@@ -463,19 +465,19 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
               \used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used)
           receive = do
             path <- asks $ filesPath . config
-            let fPath = path </> B.unpack (B64.encode senderId)
+            let fPath = path </> B.unpack (B64.encode $ unEntityId senderId)
             receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case
               Right () -> do
                 stats <- asks serverStats
                 withFileLog $ \sl -> logPutFile sl senderId fPath
                 atomically $ writeTVar filePath (Just fPath)
-                atomically $ modifyTVar' (filesUploaded stats) (+ 1)
-                atomically $ modifyTVar' (filesCount stats) (+ 1)
-                atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size)
+                incFileStat filesUploaded
+                incFileStat filesCount
+                liftIO $ atomicModifyIORef'_ (filesSize stats) (+ fromIntegral size)
                 pure FROk
               Left e -> do
                 us <- asks $ usedStorage . store
-                atomically . modifyTVar' us $ subtract (fromIntegral size)
+                atomically $ modifyTVar' us $ subtract (fromIntegral size)
                 liftIO $ whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError
                 pure $ FRErr e
           receiveChunk spec = do
@@ -494,8 +496,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
               case LC.cbInit dhSecret cbNonce of
                 Right sbState -> do
                   stats <- asks serverStats
-                  atomically $ modifyTVar' (fileDownloads stats) (+ 1)
-                  atomically $ updatePeriodStats (filesDownloaded stats) senderId
+                  incFileStat fileDownloads
+                  liftIO $ updatePeriodStats (filesDownloaded stats) senderId
                   pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
                 _ -> pure (FRErr INTERNAL, Nothing)
         _ -> pure (FRErr NO_FILE, Nothing)
@@ -511,8 +513,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       withFileLog (`logAckFile` rId)
       st <- asks store
       atomically $ deleteRecipient st rId fr
-      stats <- asks serverStats
-      atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1)
+      incFileStat fileDownloadAcks
       pure FROk
 
 deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ())
@@ -524,11 +525,14 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
     ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
     st <- asks store
     void $ atomically $ deleteFile st senderId
-    atomically $ modifyTVar' (filesDeleted stats) (+ 1)
+    lift $ incFileStat filesDeleted
   where
     deletedStats stats = do
-      atomically $ modifyTVar' (filesCount stats) (subtract 1)
-      atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
+      liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
+      liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
+
+getFileTime :: IO RoundedSystemTime
+getFileTime = getRoundedSystemTime fileTimePrecision
 
 expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
 expireServerFiles itemDelay expCfg = do
@@ -554,24 +558,21 @@ expireServerFiles itemDelay expCfg = do
     delete st sId = do
       withFileLog (`logDeleteFile` sId)
       void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store
-      FileServerStats {filesExpired} <- asks serverStats
-      atomically $ modifyTVar' filesExpired (+ 1)
+      incFileStat filesExpired
 
 randomId :: Int -> M ByteString
 randomId n = atomically . C.randomBytes n =<< asks random
 
 getFileId :: M XFTPFileId
-getFileId = do
-  size <- asks (fileIdSize . config)
-  atomically . C.randomBytes size =<< asks random
+getFileId = fmap EntityId . randomId =<< asks (fileIdSize . config)
 
 withFileLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withFileLog action = liftIO . mapM_ action =<< asks storeLog
 
-incFileStat :: (FileServerStats -> TVar Int) -> M ()
+incFileStat :: (FileServerStats -> IORef Int) -> M ()
 incFileStat statSel = do
   stats <- asks serverStats
-  atomically $ modifyTVar (statSel stats) (+ 1)
+  liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
 
 saveServerStats :: M ()
 saveServerStats =
@@ -594,7 +595,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
           FileStore {files, usedStorage} <- asks store
           _filesCount <- M.size <$> readTVarIO files
           _filesSize <- readTVarIO usedStorage
-          atomically $ setFileServerStats s d {_filesCount, _filesSize}
+          liftIO $ setFileServerStats s d {_filesCount, _filesSize}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
           when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount

src/Simplex/FileTransfer/Server/Control.hs

@@ -4,7 +4,7 @@
 module Simplex.FileTransfer.Server.Control where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString (ByteString)
+import Simplex.FileTransfer.Protocol (XFTPFileId)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth)
 
@@ -13,7 +13,7 @@ data CPClientRole = CPRNone | CPRUser | CPRAdmin
 data ControlProtocol
   = CPAuth BasicAuth
   | CPStatsRTS
-  | CPDelete ByteString
+  | CPDelete XFTPFileId
   | CPHelp
   | CPQuit
   | CPSkip

src/Simplex/FileTransfer/Server/Stats.hs

@@ -7,25 +7,24 @@ module Simplex.FileTransfer.Server.Stats where
 import Control.Applicative ((<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
+import Data.IORef
 import Data.Int (Int64)
 import Data.Time.Clock (UTCTime)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (SenderId)
 import Simplex.Messaging.Server.Stats (PeriodStats, PeriodStatsData, getPeriodStatsData, newPeriodStats, setPeriodStats)
-import UnliftIO.STM
 
 data FileServerStats = FileServerStats
-  { fromTime :: TVar UTCTime,
-    filesCreated :: TVar Int,
-    fileRecipients :: TVar Int,
-    filesUploaded :: TVar Int,
-    filesExpired :: TVar Int,
-    filesDeleted :: TVar Int,
-    filesDownloaded :: PeriodStats SenderId,
-    fileDownloads :: TVar Int,
-    fileDownloadAcks :: TVar Int,
-    filesCount :: TVar Int,
-    filesSize :: TVar Int64
+  { fromTime :: IORef UTCTime,
+    filesCreated :: IORef Int,
+    fileRecipients :: IORef Int,
+    filesUploaded :: IORef Int,
+    filesExpired :: IORef Int,
+    filesDeleted :: IORef Int,
+    filesDownloaded :: PeriodStats,
+    fileDownloads :: IORef Int,
+    fileDownloadAcks :: IORef Int,
+    filesCount :: IORef Int,
+    filesSize :: IORef Int64
   }
 
 data FileServerStatsData = FileServerStatsData
@@ -35,7 +34,7 @@ data FileServerStatsData = FileServerStatsData
     _filesUploaded :: Int,
     _filesExpired :: Int,
     _filesDeleted :: Int,
-    _filesDownloaded :: PeriodStatsData SenderId,
+    _filesDownloaded :: PeriodStatsData,
     _fileDownloads :: Int,
     _fileDownloadAcks :: Int,
     _filesCount :: Int,
@@ -45,47 +44,48 @@ data FileServerStatsData = FileServerStatsData
 
 newFileServerStats :: UTCTime -> IO FileServerStats
 newFileServerStats ts = do
-  fromTime <- newTVarIO ts
-  filesCreated <- newTVarIO 0
-  fileRecipients <- newTVarIO 0
-  filesUploaded <- newTVarIO 0
-  filesExpired <- newTVarIO 0
-  filesDeleted <- newTVarIO 0
+  fromTime <- newIORef ts
+  filesCreated <- newIORef 0
+  fileRecipients <- newIORef 0
+  filesUploaded <- newIORef 0
+  filesExpired <- newIORef 0
+  filesDeleted <- newIORef 0
   filesDownloaded <- newPeriodStats
-  fileDownloads <- newTVarIO 0
-  fileDownloadAcks <- newTVarIO 0
-  filesCount <- newTVarIO 0
-  filesSize <- newTVarIO 0
+  fileDownloads <- newIORef 0
+  fileDownloadAcks <- newIORef 0
+  filesCount <- newIORef 0
+  filesSize <- newIORef 0
   pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
 
 getFileServerStatsData :: FileServerStats -> IO FileServerStatsData
 getFileServerStatsData s = do
-  _fromTime <- readTVarIO $ fromTime (s :: FileServerStats)
-  _filesCreated <- readTVarIO $ filesCreated s
-  _fileRecipients <- readTVarIO $ fileRecipients s
-  _filesUploaded <- readTVarIO $ filesUploaded s
-  _filesExpired <- readTVarIO $ filesExpired s
-  _filesDeleted <- readTVarIO $ filesDeleted s
+  _fromTime <- readIORef $ fromTime (s :: FileServerStats)
+  _filesCreated <- readIORef $ filesCreated s
+  _fileRecipients <- readIORef $ fileRecipients s
+  _filesUploaded <- readIORef $ filesUploaded s
+  _filesExpired <- readIORef $ filesExpired s
+  _filesDeleted <- readIORef $ filesDeleted s
   _filesDownloaded <- getPeriodStatsData $ filesDownloaded s
-  _fileDownloads <- readTVarIO $ fileDownloads s
-  _fileDownloadAcks <- readTVarIO $ fileDownloadAcks s
-  _filesCount <- readTVarIO $ filesCount s
-  _filesSize <- readTVarIO $ filesSize s
+  _fileDownloads <- readIORef $ fileDownloads s
+  _fileDownloadAcks <- readIORef $ fileDownloadAcks s
+  _filesCount <- readIORef $ filesCount s
+  _filesSize <- readIORef $ filesSize s
   pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
 
-setFileServerStats :: FileServerStats -> FileServerStatsData -> STM ()
+-- this function is not thread safe, it is used on server start only
+setFileServerStats :: FileServerStats -> FileServerStatsData -> IO ()
 setFileServerStats s d = do
-  writeTVar (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData)
-  writeTVar (filesCreated s) $! _filesCreated d
-  writeTVar (fileRecipients s) $! _fileRecipients d
-  writeTVar (filesUploaded s) $! _filesUploaded d
-  writeTVar (filesExpired s) $! _filesExpired d
-  writeTVar (filesDeleted s) $! _filesDeleted d
+  writeIORef (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData)
+  writeIORef (filesCreated s) $! _filesCreated d
+  writeIORef (fileRecipients s) $! _fileRecipients d
+  writeIORef (filesUploaded s) $! _filesUploaded d
+  writeIORef (filesExpired s) $! _filesExpired d
+  writeIORef (filesDeleted s) $! _filesDeleted d
   setPeriodStats (filesDownloaded s) $! _filesDownloaded d
-  writeTVar (fileDownloads s) $! _fileDownloads d
-  writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d
-  writeTVar (filesCount s) $! _filesCount d
-  writeTVar (filesSize s) $! _filesSize d
+  writeIORef (fileDownloads s) $! _fileDownloads d
+  writeIORef (fileDownloadAcks s) $! _fileDownloadAcks d
+  writeIORef (filesCount s) $! _filesCount d
+  writeIORef (filesSize s) $! _filesSize d
 
 instance StrEncoding FileServerStatsData where
   strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} =

src/Simplex/FileTransfer/Server/Store.hs

@@ -17,6 +17,7 @@ module Simplex.FileTransfer.Server.Store
     expiredFilePath,
     getFile,
     ackFile,
+    fileTimePrecision,
   )
 where
 
@@ -25,12 +26,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Int (Int64)
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Time.Clock.System (SystemTime (..))
 import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
 import Simplex.FileTransfer.Transport (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, ($>>=))
@@ -46,9 +47,12 @@ data FileRec = FileRec
     fileInfo :: FileInfo,
     filePath :: TVar (Maybe FilePath),
     recipientIds :: TVar (Set RecipientId),
-    createdAt :: SystemTime
+    createdAt :: RoundedSystemTime
   }
 
+fileTimePrecision :: Int64
+fileTimePrecision = 3600 -- truncate creation time to 1 hour
+
 data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey
 
 instance StrEncoding FileRecipient where
@@ -62,14 +66,14 @@ newFileStore = do
   usedStorage <- newTVarIO 0
   pure FileStore {files, recipients, usedStorage}
 
-addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ())
+addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ())
 addFile FileStore {files} sId fileInfo createdAt =
   ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
     f <- newFileRec sId fileInfo createdAt
     TM.insert sId f files
     pure $ Right ()
 
-newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec
+newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
 newFileRec senderId fileInfo createdAt = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
@@ -120,8 +124,8 @@ getFile st party fId = case party of
 expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe FilePath))
 expiredFilePath FileStore {files} sId old =
   TM.lookup sId files
-    $>>= \FileRec {filePath, createdAt} ->
-      if systemSeconds createdAt < old
+    $>>= \FileRec {filePath, createdAt = RoundedSystemTime createdAt} ->
+      if createdAt + fileTimePrecision < old
         then Just <$> readTVar filePath
         else pure Nothing
 

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -28,18 +28,18 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Time.Clock.System (SystemTime)
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.FileTransfer.Server.Store
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (bshow, whenM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo SystemTime
+  = AddFile SenderId FileInfo RoundedSystemTime
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
@@ -64,7 +64,7 @@ instance StrEncoding FileStoreLogRecord where
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO ()
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO ()
 logAddFile s = logFileStoreRecord s .:. AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()

src/Simplex/FileTransfer/Types.hs

@@ -25,9 +25,9 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (XFTPServer)
 import System.FilePath ((</>))
 
-type RcvFileId = ByteString
+type RcvFileId = ByteString -- Agent entity ID
 
-type SndFileId = ByteString
+type SndFileId = ByteString -- Agent entity ID
 
 authTagSize :: Int64
 authTagSize = fromIntegral C.authTagSize

src/Simplex/Messaging/Agent.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -53,6 +54,7 @@ module Simplex.Messaging.Agent
     deleteConnectionAsync,
     deleteConnectionsAsync,
     createConnection,
+    changeConnectionUser,
     prepareConnectionToJoin,
     joinConnection,
     allowConnection,
@@ -127,7 +129,7 @@ import Control.Monad.Reader
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
-import Data.Bifunctor (bimap, first)
+import Data.Bifunctor (bimap, first, second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:), (.:.), (.::), (.::.))
@@ -165,7 +167,7 @@ import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
-import Simplex.Messaging.Client (ProtocolClient (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
+import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -173,14 +175,14 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId)
-import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
+import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), pnMessagesP)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
+import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (SMPVersion, THandleParams (sessionId))
+import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import Simplex.RemoteControl.Client
@@ -333,6 +335,11 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe
 createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs
 {-# INLINE createConnection #-}
 
+-- | Changes the user id associated with a connection
+changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
+changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId
+{-# INLINE changeConnectionUser #-}
+
 -- | Create SMP agent connection without queue (to be joined with joinConnection passing connection ID).
 -- This method is required to prevent race condition when confirmation from peer is received before
 -- the caller of joinConnection saves connection ID to the database.
@@ -467,14 +474,14 @@ testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of
 
 -- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
 setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
-setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do
-  changed <- atomically $ do
+setNetworkConfig c@AgentClient {useNetworkConfig, proxySessTs} cfg' = do
+  (spChanged, changed) <- atomically $ do
     (_, cfg) <- readTVar useNetworkConfig
-    if cfg == cfg'
-      then pure False
-      else
-        let cfgSlow = slowNetworkConfig cfg'
-         in True <$ (cfgSlow `seq` writeTVar useNetworkConfig (cfgSlow, cfg'))
+    let changed = cfg /= cfg'
+        !cfgSlow = slowNetworkConfig cfg'
+    when changed $ writeTVar useNetworkConfig (cfgSlow, cfg')
+    pure (socksProxy cfg /= socksProxy cfg', changed)
+  when spChanged $ getCurrentTime >>= atomically . writeTVar proxySessTs
   when changed $ reconnectAllServers c
 
 setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
@@ -741,6 +748,16 @@ newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe
 newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
   getSMPServer c userId >>= newConnSrv c userId connId False enableNtfs cMode clientData pqInitKeys subMode
 
+changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
+changeConnectionUser' c oldUserId connId newUserId = do
+  SomeConn _ conn <- withStore c (`getConn` connId)
+  case conn of
+    NewConnection {} -> updateConn
+    RcvConnection {} -> updateConn
+    _ -> throwE $ CMD PROHIBITED "changeConnectionUser: established connection"
+  where
+    updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
+
 newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
 newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys subMode srv = do
   connId' <-
@@ -762,7 +779,7 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
   lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
   when enableNtfs $ do
     ns <- asks ntfSupervisor
-    atomically $ sendNtfSubCommand ns (connId, NSCCreate)
+    atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
   let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
   case cMode of
     SCMContact -> pure (connId, CRContactUri crData)
@@ -875,7 +892,7 @@ joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo
   lift (compatibleContactUri cReqUri) >>= \case
     Just (qInfo, vrsn) -> do
       (connId', cReq) <- newConnSrv c userId connId hasNewConn enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
-      void $ sendInvitation c userId qInfo vrsn cReq cInfo
+      void $ sendInvitation c userId connId' qInfo vrsn cReq cInfo
       pure (connId', False)
     Nothing -> throwE $ AGENT A_VERSION
 
@@ -907,7 +924,7 @@ createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVers
   lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
   when enableNtfs $ do
     ns <- asks ntfSupervisor
-    atomically $ sendNtfSubCommand ns (connId, NSCCreate)
+    atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
   pure qInfo
 
 -- | Approve confirmation (LET command) in Reader monad
@@ -958,12 +975,12 @@ subscribeConnections' c connIds = do
   let (errs, cs) = M.mapEither id conns
       errs' = M.map (Left . storeError) errs
       (subRs, rcvQs) = M.mapEither rcvQueueOrResult cs
-  mapM_ (mapM_ (\(cData, sqs) -> mapM_ (lift . resumeMsgDelivery c cData) sqs) . sndQueue) cs
-  mapM_ (resumeConnCmds c) $ M.keys cs
+  resumeDelivery cs
+  lift $ resumeConnCmds c $ M.keys cs
   rcvRs <- lift $ connResults . fst <$> subscribeQueues c (concat $ M.elems rcvQs)
   ns <- asks ntfSupervisor
   tkn <- readTVarIO (ntfTkn ns)
-  when (instantNotifications tkn) . void . lift . forkIO . void . runExceptT $ sendNtfCreate ns rcvRs conns
+  lift $ when (instantNotifications tkn) . void . forkIO . void $ sendNtfCreate ns rcvRs cs
   let rs = M.unions ([errs', subRs, rcvRs] :: [Map ConnId (Either AgentErrorType ())])
   notifyResultError rs
   pure rs
@@ -995,15 +1012,19 @@ subscribeConnections' c connIds = do
         order (Active, _) = 2
         order (_, Right _) = 3
         order _ = 4
-    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId (Either StoreError SomeConn) -> AM ()
-    sendNtfCreate ns rcvRs conns =
-      forM_ (M.assocs rcvRs) $ \case
-        (connId, Right _) -> forM_ (M.lookup connId conns) $ \case
-          Right (SomeConn _ conn) -> do
-            let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete
-            atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
-          _ -> pure ()
-        _ -> pure ()
+    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId SomeConn -> AM' ()
+    sendNtfCreate ns rcvRs cs = do
+      let oks = M.keysSet $ M.filter (either temporaryAgentError $ const True) rcvRs
+          cs' = M.restrictKeys cs oks
+          (csCreate, csDelete) = M.partition (\(SomeConn _ conn) -> enableNtfs $ toConnData conn) cs'
+      sendNtfCmd NSCCreate csCreate
+      sendNtfCmd NSCSmpDelete csDelete
+      where
+        sendNtfCmd cmd cs' = forM_ (L.nonEmpty $ M.keys cs') $ \cids -> atomically $ writeTBQueue (ntfSubQ ns) (cmd, cids)
+    resumeDelivery :: Map ConnId SomeConn -> AM ()
+    resumeDelivery conns = do
+      conns' <- M.restrictKeys conns . S.fromList <$> withStore' c getConnectionsForDelivery
+      lift $ mapM_ (mapM_ (\(cData, sqs) -> mapM_ (resumeMsgDelivery c cData) sqs) . sndQueue) conns'
     sndQueue :: SomeConn -> Maybe (ConnData, NonEmpty SndQueue)
     sndQueue (SomeConn _ conn) = case conn of
       DuplexConnection cData _ sqs -> Just (cData, sqs)
@@ -1044,7 +1065,8 @@ getNotificationMessage' c nonce encNtfInfo = do
   withStore' c getActiveNtfToken >>= \case
     Just NtfToken {ntfDhSecret = Just dhSecret} -> do
       ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo
-      PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} <- liftEither (parse strP (INTERNAL "error parsing PNMessageData") ntfData)
+      pnMsgs <- liftEither (parse pnMessagesP (INTERNAL "error parsing PNMessageData") ntfData)
+      let PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = L.last pnMsgs
       (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
       ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
       msgMeta <- getConnectionMessage' c ntfConnId
@@ -1082,8 +1104,8 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
   where
     getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (Either AgentErrorType (MsgReq, SomeConn))
     getConn_ db prev req@(connId, _, _, _) =
-      (req,) <$$> 
-        if B.null connId
+      (req,)
+        <$$> if B.null connId
           then fromMaybe (Left $ INTERNAL "sendMessagesB_: empty prev connId") <$> readTVarIO prev
           else do
             conn <- first storeError <$> getConn db connId
@@ -1112,40 +1134,39 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
 enqueueCommand :: AgentClient -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> AM ()
 enqueueCommand c corrId connId server aCommand = do
   withStore c $ \db -> createCommand db corrId connId server aCommand
-  lift . void $ getAsyncCmdWorker True c server
+  lift . void $ getAsyncCmdWorker True c connId server
 
-resumeSrvCmds :: AgentClient -> Maybe SMPServer -> AM' ()
-resumeSrvCmds = void .: getAsyncCmdWorker False
+resumeSrvCmds :: AgentClient -> ConnId -> Maybe SMPServer -> AM' ()
+resumeSrvCmds = void .:. getAsyncCmdWorker False
 {-# INLINE resumeSrvCmds #-}
 
-resumeConnCmds :: AgentClient -> ConnId -> AM ()
-resumeConnCmds c connId =
-  unlessM connQueued $
-    withStore' c (`getPendingCommandServers` connId)
-      >>= mapM_ (lift . resumeSrvCmds c)
-  where
-    connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
+resumeConnCmds :: AgentClient -> [ConnId] -> AM' ()
+resumeConnCmds c connIds = do
+  connSrvs <- rights . zipWith (second . (,)) connIds <$> withStoreBatch' c (\db -> fmap (getPendingCommandServers db) connIds)
+  mapM_ (\(connId, srvs) -> mapM_ (resumeSrvCmds c connId) srvs) connSrvs
 
-getAsyncCmdWorker :: Bool -> AgentClient -> Maybe SMPServer -> AM' Worker
-getAsyncCmdWorker hasWork c server =
-  getAgentWorker "async_cmd" hasWork c server (asyncCmdWorkers c) (runCommandProcessing c server)
+getAsyncCmdWorker :: Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
+getAsyncCmdWorker hasWork c connId server =
+  getAgentWorker "async_cmd" hasWork c (connId, server) (asyncCmdWorkers c) (runCommandProcessing c connId server)
 
-runCommandProcessing :: AgentClient -> Maybe SMPServer -> Worker -> AM ()
-runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
+data CommandCompletion = CCMoved | CCCompleted
+
+runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM ()
+runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
   ri <- asks $ messageRetryInterval . config -- different retry interval?
   forever $ do
     atomically $ endAgentOperation c AOSndNetwork
     lift $ waitForWork doWork
     liftIO $ throwWhenInactive c
     atomically $ beginAgentOperation c AOSndNetwork
-    withWork c doWork (`getPendingServerCommand` server_) $ runProcessCmd (riFast ri)
+    withWork c doWork (\db -> getPendingServerCommand db connId server_) $ runProcessCmd (riFast ri)
   where
     runProcessCmd ri cmd = do
       pending <- newTVarIO []
       processCmd ri cmd pending
       mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending
     processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM ()
-    processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} pendingCmds = case command of
+    processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of
       AClientCommand cmd -> case cmd of
         NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
@@ -1171,16 +1192,27 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
       AInternalCommand cmd -> case cmd of
         ICAckDel rId srvMsgId msgId -> withServer $ \srv -> tryWithLock "ICAckDel" $ ack srv rId srvMsgId >> withStore' c (\db -> deleteMsg db connId msgId)
         ICAck rId srvMsgId -> withServer $ \srv -> tryWithLock "ICAck" $ ack srv rId srvMsgId
-        ICAllowSecure _rId senderKey -> withServer' . tryWithLock "ICAllowSecure" $ do
+        ICAllowSecure _rId senderKey -> withServer' . tryMoveableWithLock "ICAllowSecure" $ do
           (SomeConn _ conn, AcceptedConfirmation {senderConf, ownConnInfo}) <-
             withStore c $ \db -> runExceptT $ (,) <$> ExceptT (getConn db connId) <*> ExceptT (getAcceptedConfirmation db connId)
           case conn of
             RcvConnection cData rq -> do
               mapM_ (secure rq) senderKey
               mapM_ (connectReplyQueues c cData ownConnInfo Nothing) (L.nonEmpty $ smpReplyQueues senderConf)
+              pure CCCompleted
             -- duplex connection is matched to handle SKEY retries
-            DuplexConnection cData _ (sq :| _) ->
-              mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf)
+            DuplexConnection cData _ (sq :| _) -> do
+              tryAgentError (mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf)) >>= \case
+                Right () -> pure CCCompleted
+                Left e
+                  | temporaryOrHostError e && Just server /= server_ -> do
+                      -- In case the server is different we update server to remove command from this (connId, srv) queue
+                      withStore c $ \db -> updateCommandServer db cmdId server
+                      lift . void $ getAsyncCmdWorker True c connId (Just server)
+                      pure CCMoved
+                  | otherwise -> throwE e
+              where
+                server = qServer sq
             _ -> throwE $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd)
         ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do
           secure rq senderKey
@@ -1227,7 +1259,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
                     withStore' c $ \db -> deleteConnRcvQueue db rq'
                     when (enableNtfs cData) $ do
                       ns <- asks ntfSupervisor
-                      atomically $ sendNtfSubCommand ns (connId, NSCCreate)
+                      atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
                     let conn' = DuplexConnection cData (rq'' :| rqs') sqs
                     notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
               _ -> internalErr "ICQDelete: cannot delete the only queue in connection"
@@ -1253,15 +1285,18 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
           withStore c (`getConn` connId) >>= \case
             SomeConn _ conn@DuplexConnection {} -> a conn
             _ -> internalErr "command requires duplex connection"
-        tryCommand action = withRetryInterval ri $ \_ loop -> do
+        tryCommand action = tryMoveableCommand (action $> CCCompleted)
+        tryMoveableCommand action = withRetryInterval ri $ \_ loop -> do
           liftIO $ waitWhileSuspended c
           liftIO $ waitForUserNetwork c
-          tryError action >>= \case
+          tryAgentError action >>= \case
             Left e
               | temporaryOrHostError e -> retrySndOp c loop
               | otherwise -> cmdError e
-            Right () -> withStore' c (`deleteCommand` cmdId)
+            Right CCCompleted -> withStore' c (`deleteCommand` cmdId)
+            Right CCMoved -> pure () -- command processing moved to another command queue
         tryWithLock name = tryCommand . withConnLock c connId name
+        tryMoveableWithLock name = tryMoveableCommand . withConnLock c connId name
         internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
         cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
         notify :: forall e. AEntityI e => AEvent e -> AM ()
@@ -1309,7 +1344,7 @@ enqueueMessageB c reqs = do
     storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
       let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg
       internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
+      (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
           agentMsg = AgentMessage privHeader aMessage
           agentMsgStr = smpEncode agentMsg
@@ -1681,12 +1716,6 @@ connRcvQueues = \case
   SndConnection _ _ -> []
   NewConnection _ -> []
 
-disableConn :: AgentClient -> ConnId -> AM' ()
-disableConn c connId = do
-  atomically $ removeSubscription c connId
-  ns <- asks ntfSupervisor
-  atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
-
 -- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
 deleteConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
 deleteConnections' = deleteConnections_ getConns False False
@@ -1713,7 +1742,7 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
       (delRs, rcvQs) = M.mapEither rcvQueues cs
       rqs = concat $ M.elems rcvQs
       connIds' = M.keys rcvQs
-  lift . forM_ connIds' $ disableConn c
+  lift $ forM_ (L.nonEmpty connIds') unsubConnIds
   -- ! delRs is not used to notify about the result in any of the calling functions,
   -- ! it is only used to check results count in deleteConnections_;
   -- ! if it was used to notify about the result, it might be necessary to differentiate
@@ -1727,6 +1756,12 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
     rcvQueues (SomeConn _ conn) = case connRcvQueues conn of
       [] -> Left $ Right ()
       rqs -> Right rqs
+    unsubConnIds :: NonEmpty ConnId -> AM' ()
+    unsubConnIds connIds' = do
+      forM_ connIds' $ \connId ->
+        atomically $ removeSubscription c connId
+      ns <- asks ntfSupervisor
+      atomically $ writeTBQueue (ntfSubQ ns) (NSCDeleteSub, connIds')
     notify = atomically . writeTBQueue (subQ c)
 
 deleteConnQueues :: AgentClient -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ()))
@@ -1867,7 +1902,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
                 cron <- asks $ ntfCron . config
                 agentNtfEnableCron c tknId tkn cron
                 when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
-                when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete
+                when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
               -- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
               pure ntfTknStatus
           | otherwise -> replaceToken tknId
@@ -1949,7 +1984,7 @@ deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
 deleteNtfToken' c deviceToken =
   withStore' c getSavedNtfToken >>= \case
     Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
-      when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "deleteNtfToken: different token"
+      when (deviceToken /= savedDeviceToken) $ logWarn "deleteNtfToken: different token"
       deleteToken_ c tkn
       deleteNtfSubs c NSCSmpDelete
     _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
@@ -1982,21 +2017,22 @@ toggleConnectionNtfs' c connId enable = do
       | otherwise = do
           withStore' c $ \db -> setConnectionNtfs db connId enable
           ns <- asks ntfSupervisor
-          let cmd = if enable then NSCCreate else NSCDelete
-          atomically $ sendNtfSubCommand ns (connId, cmd)
+          let cmd = if enable then NSCCreate else NSCSmpDelete
+          atomically $ sendNtfSubCommand ns (cmd, [connId])
 
 deleteToken_ :: AgentClient -> NtfToken -> AM ()
-deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
+deleteToken_ c@AgentClient {subQ} tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
   ns <- asks ntfSupervisor
   forM_ ntfTokenId $ \tknId -> do
     let ntfTknAction = Just NTADelete
     withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction
     atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction}
-    agentNtfDeleteToken c tknId tkn `catchAgentError` \case
-      NTF _ AUTH -> pure ()
-      e -> throwE e
+    agentNtfDeleteToken c tknId tkn `catchAgentError` \e -> notify (ERR e) -- TODO cleanup task
   withStore' c $ \db -> removeNtfToken db tkn
   atomically $ nsRemoveNtfToken ns
+  where
+    notify :: forall e. AEntityI e => AEvent e -> AM ()
+    notify cmd = atomically $ writeTBQueue subQ ("", "", AEvt (sAEntity @e) cmd)
 
 withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
 withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
@@ -2030,13 +2066,24 @@ deleteNtfSubs c deleteCmd = do
 sendNtfConnCommands :: AgentClient -> NtfSupervisorCommand -> AM ()
 sendNtfConnCommands c cmd = do
   ns <- asks ntfSupervisor
-  connIds <- liftIO $ getSubscriptions c
-  forM_ connIds $ \connId -> do
-    withStore' c (`getConnData` connId) >>= \case
-      Just (ConnData {enableNtfs}, _) ->
-        when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
-      _ ->
-        atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ ERR $ INTERNAL "no connection data")
+  connIds <- liftIO $ S.toList <$> getSubscriptions c
+  rs <- lift $ withStoreBatch' c (\db -> map (getConnData db) connIds)
+  let (connIds', cErrs) = enabledNtfConns (zip connIds rs)
+  forM_ (L.nonEmpty connIds') $ \connIds'' ->
+    atomically $ writeTBQueue (ntfSubQ ns) (cmd, connIds'')
+  unless (null cErrs) $ atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS cErrs)
+  where
+    enabledNtfConns :: [(ConnId, Either AgentErrorType (Maybe (ConnData, ConnectionMode)))] -> ([ConnId], [(ConnId, AgentErrorType)])
+    enabledNtfConns = foldr addEnabledConn ([], [])
+      where
+        addEnabledConn ::
+          (ConnId, Either AgentErrorType (Maybe (ConnData, ConnectionMode))) ->
+          ([ConnId], [(ConnId, AgentErrorType)]) ->
+          ([ConnId], [(ConnId, AgentErrorType)])
+        addEnabledConn cData_ (cIds, errs) = case cData_ of
+          (_, Right (Just (ConnData {connId, enableNtfs}, _))) -> if enableNtfs then (connId : cIds, errs) else (cIds, errs)
+          (connId, Right Nothing) -> (cIds, (connId, INTERNAL "no connection data") : errs)
+          (connId, Left e) -> (cIds, (connId, e) : errs)
 
 setNtfServers :: AgentClient -> [NtfServer] -> IO ()
 setNtfServers c = atomically . writeTVar (ntfServers c)
@@ -2174,7 +2221,7 @@ cleanupManager c@AgentClient {subQ} = do
     deleteExpiredReplicasForDeletion = do
       rcvFilesTTL <- asks $ rcvFilesTTL . config
       withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL)
-    notify :: forall e. AEntityI e => EntityId -> AEvent e -> AM ()
+    notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM ()
     notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd)
 
 data ACKd = ACKd | ACKPending
@@ -2311,7 +2358,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
                               HELLO -> helloMsg srvMsgId msgMeta conn'' >> ackDel msgId
                               -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
                               A_MSG body -> do
-                                logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
+                                logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret' srvMsgId
                                 notify $ MSG msgMeta msgFlags body
                                 pure ACKPending
                               A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta
@@ -2321,7 +2368,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
                               QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs
                               -- no action needed for QTEST
                               -- any message in the new queue will mark it active and trigger deletion of the old queue
-                              QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret srvMsgId) >> ackDel msgId
+                              QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret' srvMsgId) >> ackDel msgId
                               EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev
                             where
                               qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> AM ()) -> AM ACKd
@@ -2344,7 +2391,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
                                 | otherwise ->
                                     liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
                                       AgentMessage _ (A_MSG body) -> do
-                                        logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
+                                        logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret' srvMsgId
                                         notify $ MSG msgMeta msgFlags body
                                         pure ACKPending
                                       _ -> ack
@@ -2415,17 +2462,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
               handleNotifyAck :: AM ACKd -> AM ACKd
               handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack
           SMP.END ->
-            atomically (TM.lookup tSess (smpClients c) $>>= (tryReadTMVar . sessionVar) >>= processEND)
+            atomically (ifM (activeClientSession c tSess sessId) (removeSubscription c connId $> True) (pure False))
               >>= notifyEnd
             where
-              processEND = \case
-                Just (Right clnt)
-                  | sessId == sessionId (thParams $ connectedClient clnt) ->
-                      removeSubscription c connId $> True
-                _ -> pure False
               notifyEnd removed
                 | removed = notify END >> logServer "<--" c srv rId "END"
                 | otherwise = logServer "<--" c srv rId "END from disconnected client - ignored"
+          -- Possibly, we need to add some flag to connection that it was deleted
+          SMP.DELD -> atomically (removeSubscription c connId) >> notify DELD
           SMP.ERR e -> notify $ ERR $ SMP (B.unpack $ strEncode srv) e
           r -> unexpected r
         where
@@ -2466,7 +2510,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
 
           smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM ()
           smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
-            logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret srvMsgId
+            logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret' srvMsgId
             AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
             let ConnData {pqSupport} = toConnData conn'
             unless
@@ -2535,7 +2579,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
 
           helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM ()
           helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do
-            logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret srvMsgId
+            logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret' srvMsgId
             case status of
               Active -> prohibited "hello: active"
               _ ->
@@ -2559,7 +2603,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
           continueSending srvMsgId addr (DuplexConnection _ _ sqs) =
             case findQ addr sqs of
               Just sq -> do
-                logServer "<--" c srv rId $ "MSG <QCONT>:" <> logSecret srvMsgId
+                logServer "<--" c srv rId $ "MSG <QCONT>:" <> logSecret' srvMsgId
                 atomically $
                   TM.lookup (qAddress sq) (smpDeliveryWorkers c)
                     >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ())
@@ -2568,7 +2612,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
 
           messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd
           messagesRcvd rcpts msgMeta@MsgMeta {broker = (srvMsgId, _)} _ = do
-            logServer "<--" c srv rId $ "MSG <RCPT>:" <> logSecret srvMsgId
+            logServer "<--" c srv rId $ "MSG <RCPT>:" <> logSecret' srvMsgId
             rs <- forM rcpts $ \rcpt -> clientReceipt rcpt `catchAgentError` \e -> notify (ERR e) $> Nothing
             case L.nonEmpty . catMaybes $ L.toList rs of
               Just rs' -> notify (RCVD msgMeta rs') $> ACKPending
@@ -2608,7 +2652,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
                         sq2 <- withStore c $ \db -> do
                           liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs
                           addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-                        logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress)
+                        logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret' srvMsgId <> " " <> logSecret (senderId queueAddress)
                         let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
                         void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPublicKey)]
                         sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
@@ -2629,7 +2673,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
               Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'}
                 | status' == New || status' == Confirmed -> do
                     checkRQSwchStatus rq RSSendingQADD
-                    logServer "<--" c srv rId $ "MSG <QKEY>:" <> logSecret srvMsgId <> " " <> logSecret senderId
+                    logServer "<--" c srv rId $ "MSG <QKEY>:" <> logSecret' srvMsgId <> " " <> logSecret senderId
                     let dhSecret = C.dh' dhPublicKey dhPrivKey
                     withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
                     enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey
@@ -2650,7 +2694,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
                 case find ((replaceQId ==) . dbQId) sqs of
                   Just sq1 -> do
                     checkSQSwchStatus sq1 SSSendingQKEY
-                    logServer "<--" c srv rId $ "MSG <QUSE>:" <> logSecret srvMsgId <> " " <> logSecret (snd addr)
+                    logServer "<--" c srv rId $ "MSG <QUSE>:" <> logSecret' srvMsgId <> " " <> logSecret (snd addr)
                     withStore' c $ \db -> setSndQueueStatus db sq' Secured
                     let sq'' = (sq' :: SndQueue) {status = Secured}
                     -- sending QTEST to the new queue only, the old one will be removed if sent successfully
@@ -2674,7 +2718,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
 
           smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM ()
           smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
-            logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret srvMsgId
+            logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret' srvMsgId
             case conn' of
               ContactConnection {} -> do
                 -- show connection request even if invitaion via contact address is not compatible.
@@ -2819,7 +2863,7 @@ secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv
       currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
       withStore c $ \db -> runExceptT $ do
         let agentMsgBody = smpEncode aMessage
-        (_, internalSndId, _) <- liftIO $ updateSndIds db connId
+        (_, internalSndId, _) <- ExceptT $ updateSndIds db connId
         liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody)
         let pqEnc = CR.pqSupportToEnc pqSupport
         (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion
@@ -2852,7 +2896,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq
   currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
   withStore c $ \db -> runExceptT $ do
     internalTs <- liftIO getCurrentTime
-    (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
+    (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
     let agentMsgStr = smpEncode agentMsg
         internalHash = C.sha256Hash agentMsgStr
         pqEnc = CR.pqSupportToEnc pqSupport
@@ -2878,7 +2922,7 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
     storeRatchetKey :: VersionSMPA -> AM InternalId
     storeRatchetKey agentVersion = withStore c $ \db -> runExceptT $ do
       internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
+      (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
       let agentMsg = AgentRatchetInfo ""
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr

src/Simplex/Messaging/Agent/Client.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
@@ -55,8 +56,10 @@ module Simplex.Messaging.Agent.Client
     secureQueue,
     secureSndQueue,
     enableQueueNotifications,
+    EnableQueueNtfReq (..),
     enableQueuesNtfs,
     disableQueueNotifications,
+    DisableQueueNtfReq,
     disableQueuesNtfs,
     sendAgentMessage,
     getQueueInfo,
@@ -67,6 +70,7 @@ module Simplex.Messaging.Agent.Client
     agentNtfDeleteToken,
     agentNtfEnableCron,
     agentNtfCreateSubscription,
+    agentNtfCreateSubscriptions,
     agentNtfCheckSubscription,
     agentNtfDeleteSubscription,
     agentXFTPDownloadChunk,
@@ -82,6 +86,7 @@ module Simplex.Messaging.Agent.Client
     deleteQueues,
     logServer,
     logSecret,
+    logSecret',
     removeSubscription,
     hasActiveSubscription,
     hasPendingSubscription,
@@ -113,6 +118,7 @@ module Simplex.Messaging.Agent.Client
     hasWorkToDo,
     hasWorkToDo',
     withWork,
+    withWorkItems,
     agentOperations,
     agentOperationBracket,
     waitUntilActive,
@@ -163,7 +169,7 @@ module Simplex.Messaging.Agent.Client
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent (ThreadId, forkIO)
+import Control.Concurrent (ThreadId, killThread)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (retry)
 import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
@@ -183,7 +189,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Either (isRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (deleteFirstsBy, foldl', partition, (\\))
+import Data.List (deleteFirstsBy, find, foldl', partition, (\\))
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -228,7 +234,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumT
 import Simplex.Messaging.Protocol
   ( AProtocolType (..),
     BrokerMsg,
-    EntityId,
+    EntityId (..),
     ErrorType,
     MsgFlags (..),
     MsgId,
@@ -241,7 +247,6 @@ import Simplex.Messaging.Protocol
     ProtocolServer (..),
     ProtocolType (..),
     ProtocolTypeI (..),
-    QueueId,
     QueueIdsKeys (..),
     RcvMessage (..),
     RcvNtfPublicDhKey,
@@ -256,6 +261,7 @@ import Simplex.Messaging.Protocol
     XFTPServer,
     XFTPServerWithAuth,
     sameSrvAddr',
+    pattern NoEntity,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.QueueStore.QueueInfo
@@ -266,10 +272,11 @@ import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessio
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
-import System.Mem.Weak (Weak)
+import System.Mem.Weak (Weak, deRefWeak)
 import System.Random (randomR)
 import UnliftIO (mapConcurrently, timeout)
 import UnliftIO.Async (async)
+import UnliftIO.Concurrent (forkIO, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -312,8 +319,7 @@ data AgentClient = AgentClient
     removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
     workerSeq :: TVar Int,
     smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
-    asyncCmdWorkers :: TMap (Maybe SMPServer) Worker,
-    connCmdsQueued :: TMap ConnId Bool,
+    asyncCmdWorkers :: TMap (ConnId, Maybe SMPServer) Worker,
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -331,6 +337,7 @@ data AgentClient = AgentClient
     smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
     clientId :: Int,
     agentEnv :: Env,
+    proxySessTs :: TVar UTCTime,
     smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats,
     xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats,
     ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats,
@@ -411,7 +418,7 @@ runWorkerAsync Worker {action} work =
     (atomically . tryPutTMVar action) -- if it was running (or if start crashes), put it back and unlock (don't lock if it was just started)
     (\a -> when (isNothing a) start) -- start worker if it's not running
   where
-    start = atomically . putTMVar action . Just =<< async work
+    start = atomically . putTMVar action . Just =<< mkWeakThreadId =<< forkIO work
 
 data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
   deriving (Eq, Show)
@@ -459,6 +466,7 @@ newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> IO AgentClient
 newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do
   let cfg = config agentEnv
       qSize = tbqSize cfg
+  proxySessTs <- newTVarIO =<< getCurrentTime
   acThread <- newTVarIO Nothing
   active <- newTVarIO True
   subQ <- newTBQueueIO qSize
@@ -480,7 +488,6 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
   workerSeq <- newTVarIO 0
   smpDeliveryWorkers <- TM.emptyIO
   asyncCmdWorkers <- TM.emptyIO
-  connCmdsQueued <- TM.emptyIO
   ntfNetworkOp <- newTVarIO $ AgentOpState False 0
   rcvNetworkOp <- newTVarIO $ AgentOpState False 0
   msgDeliveryOp <- newTVarIO $ AgentOpState False 0
@@ -519,7 +526,6 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
         workerSeq,
         smpDeliveryWorkers,
         asyncCmdWorkers,
-        connCmdsQueued,
         ntfNetworkOp,
         rcvNetworkOp,
         msgDeliveryOp,
@@ -533,6 +539,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
         smpSubWorkers,
         clientId,
         agentEnv,
+        proxySessTs,
         smpServersStats,
         xftpServersStats,
         ntfServersStats,
@@ -657,7 +664,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
         Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
 
 smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
-smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
+smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) prs v =
   newProtocolClient c tSess smpClients connectClient v
     `catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
   where
@@ -667,7 +674,8 @@ smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
       g <- asks random
       env <- ask
       liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
-        smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) $ smpClientDisconnected c tSess env v' prs
+        ts <- readTVarIO proxySessTs
+        smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
         pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
 
 smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
@@ -756,7 +764,7 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
     notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
 
 getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
-getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv, _) = do
+getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
   unlessM (readTVarIO active) $ throwE INACTIVE
   ts <- liftIO getCurrentTime
   atomically (getSessVar workerSeq tSess ntfClients ts)
@@ -768,8 +776,9 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv,
     connectClient v = do
       cfg <- lift $ getClientConfig c ntfCfg
       g <- asks random
+      ts <- readTVarIO proxySessTs
       liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
-        getProtocolClient g tSess cfg Nothing $
+        getProtocolClient g tSess cfg Nothing ts $
           clientDisconnected v
 
     clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
@@ -779,7 +788,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv,
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
-getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv, _) = do
+getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
   unlessM (readTVarIO active) $ throwE INACTIVE
   ts <- liftIO getCurrentTime
   atomically (getSessVar workerSeq tSess xftpClients ts)
@@ -791,8 +800,9 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv
     connectClient v = do
       cfg <- asks $ xftpCfg . config
       xftpNetworkConfig <- getNetworkConfig c
+      ts <- readTVarIO proxySessTs
       liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
-        X.getXFTPClient tSess cfg {xftpNetworkConfig} $
+        X.getXFTPClient tSess cfg {xftpNetworkConfig} ts $
           clientDisconnected v
 
     clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
@@ -893,7 +903,6 @@ closeAgentClient c = do
   atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect
   clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst)
   clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker
-  clear connCmdsQueued
   atomically . RQ.clear $ activeSubs c
   atomically . RQ.clear $ pendingSubs c
   clear subscrConns
@@ -909,7 +918,7 @@ closeAgentClient c = do
 cancelWorker :: Worker -> IO ()
 cancelWorker Worker {doWork, action} = do
   noWorkToDo doWork
-  atomically (tryTakeTMVar action) >>= mapM_ (mapM_ uninterruptibleCancel)
+  atomically (tryTakeTMVar action) >>= mapM_ (mapM_ $ deRefWeak >=> mapM_ killThread)
 
 waitUntilActive :: AgentClient -> IO ()
 waitUntilActive AgentClient {active} = unlessM (readTVarIO active) $ atomically $ unlessM (readTVar active) retry
@@ -999,7 +1008,7 @@ withClient_ c tSess@(_, srv, _) action = do
   where
     logServerError :: AgentErrorType -> AM a
     logServerError e = do
-      logServer "<--" c srv "" $ bshow e
+      logServer "<--" c srv NoEntity $ bshow e
       throwE e
 
 withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
@@ -1016,32 +1025,32 @@ withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
     proxySrv = showServer . protocolClientServer' . protocolClient
     logServerError :: SMPConnectedClient -> AgentErrorType -> AM a
     logServerError cl e = do
-      logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e
+      logServer ("<-- " <> proxySrv cl <> " <") c destSrv NoEntity $ bshow e
       throwE e
 
-withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a
+withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
 withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
-  logServer "-->" c srv entId cmdStr
+  logServer' "-->" c srv entId cmdStr
   res <- withClient_ c tSess action
-  logServer "<--" c srv entId "OK"
+  logServer' "<--" c srv entId "OK"
   return res
 
 withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
 withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
 {-# INLINE withClient #-}
 
-withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
+withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
 withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
 {-# INLINE withLogClient #-}
 
 withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
 withSMPClient c q cmdStr action = do
   tSess <- mkSMPTransportSession c q
-  withLogClient c tSess (queueId q) cmdStr $ action . connectedClient
+  withLogClient c tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
 
-sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
-sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg =
-  sendOrProxySMPCommand c userId destSrv cmdStr senderId sendViaProxy sendDirectly
+sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
+sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags msg =
+  sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
   where
     sendViaProxy smp proxySess = do
       atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
@@ -1055,14 +1064,15 @@ sendOrProxySMPCommand ::
   AgentClient ->
   UserId ->
   SMPServer ->
+  ConnId ->
   ByteString ->
   SMP.SenderId ->
   (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
   (SMPClient -> ExceptT SMPClientError IO ()) ->
   AM (Maybe SMPServer)
-sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
-  sess <- mkTransportSession c userId destSrv senderId
-  ifM shouldUseProxy (sendViaProxy Nothing sess) (sendDirectly sess $> Nothing)
+sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
+  tSess <- mkTransportSession c userId destSrv connId
+  ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
   where
     shouldUseProxy = do
       cfg <- getNetworkConfig c
@@ -1081,7 +1091,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi
         SPFProhibit -> False
     unknownServer = liftIO $ maybe True (notElem destSrv . knownSrvs) <$> TM.lookupIO userId (smpServers c)
     sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
-    sendViaProxy proxySrv_ destSess@(_, _, qId) = do
+    sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
       r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
         r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
         let proxySrv = protocolClientServer' smp
@@ -1108,7 +1118,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi
               -- checks that the current proxied relay session is the same one that was used to send the message and removes it
               deleteRelaySession =
                 ( TM.lookup destSess (smpProxiedRelays c)
-                    $>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, qId) (smpClients c)
+                    $>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, connId_) (smpClients c)
                 )
                   >>= \case
                     Just (Right (SMPConnectedClient smp' prs))
@@ -1128,7 +1138,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi
           | serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e)
           | otherwise -> throwE e
     sendDirectly tSess =
-      withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
+      withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
         r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp
         case r of
           Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect
@@ -1141,18 +1151,18 @@ ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts
     isOnionHost = \case THOnionHost _ -> True; _ -> False
 
 withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
-withNtfClient c srv = withLogClient c (0, srv, Nothing)
+withNtfClient c srv (EntityId entId) = withLogClient c (0, srv, Nothing) entId
 
 withXFTPClient ::
   ProtocolServerClient v err msg =>
   AgentClient ->
-  (UserId, ProtoServer msg, EntityId) ->
+  (UserId, ProtoServer msg, ByteString) ->
   ByteString ->
   (Client msg -> ExceptT (ProtocolClientError err) IO b) ->
   AM b
-withXFTPClient c (userId, srv, entityId) cmdStr action = do
-  tSess <- mkTransportSession c userId srv entityId
-  withLogClient c tSess entityId cmdStr action
+withXFTPClient c (userId, srv, sessEntId) cmdStr action = do
+  tSess <- mkTransportSession c userId srv sessEntId
+  withLogClient c tSess sessEntId cmdStr action
 
 liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a
 liftClient protocolError_ = liftError . protocolClientError protocolError_
@@ -1199,7 +1209,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
   g <- asks random
   liftIO $ do
     let tSess = (userId, srv, Nothing)
-    getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
+    ts <- readTVarIO $ proxySessTs c
+    getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
       Right smp -> do
         rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
         (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
@@ -1229,7 +1240,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
   rcvPath <- getTempFilePath workDir
   liftIO $ do
     let tSess = (userId, srv, Nothing)
-    X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
+    ts <- readTVarIO $ proxySessTs c
+    X.getXFTPClient tSess cfg {xftpNetworkConfig} ts (\_ -> pure ()) >>= \case
       Right xftp -> withTestChunk filePath $ do
         (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
         (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1273,7 +1285,8 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
   g <- asks random
   liftIO $ do
     let tSess = (userId, srv, Nothing)
-    getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
+    ts <- readTVarIO $ proxySessTs c
+    getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
       Right ntf -> do
         (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
         (dhKey, _) <- atomically $ C.generateKeyPair g
@@ -1294,12 +1307,12 @@ getXFTPWorkPath = do
   workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
   maybe getTemporaryDirectory pure workDir
 
-mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
-mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c
+mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> ByteString -> m (TransportSession msg)
+mkTransportSession c userId srv sessEntId = mkTSession userId srv sessEntId <$> getSessionMode c
 {-# INLINE mkTransportSession #-}
 
-mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg
-mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing)
+mkTSession :: UserId -> ProtoServer msg -> ByteString -> TransportSessionMode -> TransportSession msg
+mkTSession userId srv sessEntId mode = (userId, srv, if mode == TSMEntity then Just sessEntId else Nothing)
 {-# INLINE mkTSession #-}
 
 mkSMPTransportSession :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession
@@ -1321,12 +1334,12 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender
   rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
   (dhKey, privDhKey) <- atomically $ C.generateKeyPair g
   (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
-  logServer "-->" c srv "" "NEW"
+  logServer "-->" c srv NoEntity "NEW"
   tSess <- mkTransportSession c userId srv connId
   (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <-
     withClient c tSess $ \(SMPConnectedClient smp _) ->
       (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure
-  liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
+  liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
           { userId,
@@ -1410,7 +1423,7 @@ subscribeQueues c qs = do
     checkQueue rq = do
       prohibited <- liftIO $ hasGetLock c rq
       pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
-    subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
+    subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
     subscribeQueues_ env session smp qs' = do
       let (userId, srv, _) = transportSession' smp
       atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
@@ -1441,31 +1454,33 @@ activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClien
       Just (Right (SMPConnectedClient smp _)) -> sessId == sessionId (thParams smp)
       _ -> False
 
-type BatchResponses e r = NonEmpty (RcvQueue, Either e r)
+type BatchResponses q e r = NonEmpty (q, Either e r)
 
-sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)]
+-- Please note: this function does not preserve order of results to be the same as the order of arguments,
+-- it includes arguments in the results instead.
+sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> [q] -> AM' [(q, Either AgentErrorType r)]
 sendTSessionBatches statCmd toRQ action c qs =
   concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
   where
     batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
     batchQueues = do
       mode <- getSessionMode c
-      pure . M.assocs $ foldl' (batch mode) M.empty qs
+      pure . M.assocs $ foldr (batch mode) M.empty qs
       where
-        batch mode m q =
+        batch mode q m =
           let tSess = mkSMPTSession (toRQ q) mode
            in M.alter (Just . maybe [q] (q <|)) tSess m
-    sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses AgentErrorType r)
+    sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
     sendClientBatch (tSess@(_, srv, _), qs') =
       tryAgentError' (getSMPServerClient c tSess) >>= \case
-        Left e -> pure $ L.map ((,Left e) . toRQ) qs'
+        Left e -> pure $ L.map (,Left e) qs'
         Right (SMPConnectedClient smp _) -> liftIO $ do
-          logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
+          logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
           L.map agentError <$> action smp qs'
           where
             agentError = second . first $ protocolClientError SMP $ clientServer smp
 
-sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
+sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
 sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
   where
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
@@ -1514,32 +1529,39 @@ getSubscriptions :: AgentClient -> IO (Set ConnId)
 getSubscriptions = readTVarIO . subscrConns
 {-# INLINE getSubscriptions #-}
 
-logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
-logServer dir AgentClient {clientId} srv qId cmdStr =
-  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
+logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m ()
+logServer dir c srv = logServer' dir c srv . unEntityId
 {-# INLINE logServer #-}
 
+logServer' :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> ByteString -> ByteString -> m ()
+logServer' dir AgentClient {clientId} srv qStr cmdStr =
+  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret' qStr, cmdStr]
+
 showServer :: ProtocolServer s -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)
 {-# INLINE showServer #-}
 
-logSecret :: ByteString -> ByteString
-logSecret bs = B64.encode $ B.take 3 bs
+logSecret :: EntityId -> ByteString
+logSecret = logSecret' . unEntityId
 {-# INLINE logSecret #-}
 
+logSecret' :: ByteString -> ByteString
+logSecret' = B64.encode . B.take 3
+{-# INLINE logSecret' #-}
+
 sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer)
-sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
+sendConfirmation c sq@SndQueue {userId, server, connId, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
   let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing)
       clientMsg = SMP.ClientMessage privHdr agentConfirmation
   msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
-  sendOrProxySMPMessage c userId server "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
+  sendOrProxySMPMessage c userId server connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
 sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
-sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
-sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
+sendInvitation :: AgentClient -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
+sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
   msg <- mkInvitation
-  sendOrProxySMPMessage c userId smpServer "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
+  sendOrProxySMPMessage c userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
   where
     mkInvitation :: AM ByteString
     -- this is only encrypted with per-queue E2E, not with double ratchet
@@ -1575,8 +1597,8 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
 secureSndQueue :: AgentClient -> SndQueue -> AM ()
-secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} =
-  void $ sendOrProxySMPCommand c userId server "SKEY <key>" sndId secureViaProxy secureDirectly
+secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
+  void $ sendOrProxySMPCommand c userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
   where
     -- TODO track statistics
     secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
@@ -1587,26 +1609,43 @@ enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtf
   withSMPClient c rq "NKEY <nkey>" $ \smp ->
     enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
 
-enableQueuesNtfs :: AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> AM' [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
-enableQueuesNtfs = sendTSessionBatches "NKEY" fst3 enableQueues_
+data EnableQueueNtfReq = EnableQueueNtfReq
+  { eqnrNtfSub :: NtfSubscription,
+    eqnrRq :: RcvQueue,
+    eqnrAuthKeyPair :: C.AAuthKeyPair,
+    eqnrRcvKeyPair :: C.KeyPairX25519
+  }
+
+enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
+enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
   where
-    fst3 (x, _, _) = x
-    enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
-    enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
-    queueCreds :: (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
-    queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey)
+    enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
+    enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
+    queueCreds :: EnableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
+    queueCreds EnableQueueNtfReq {eqnrRq, eqnrAuthKeyPair, eqnrRcvKeyPair} =
+      let RcvQueue {rcvPrivateKey, rcvId} = eqnrRq
+          (ntfPublicKey, _) = eqnrAuthKeyPair
+          (rcvNtfPubDhKey, _) = eqnrRcvKeyPair
+       in (rcvPrivateKey, rcvId, ntfPublicKey, rcvNtfPubDhKey)
 
 disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
 disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
   withSMPClient c rq "NDEL" $ \smp ->
     disableSMPQueueNotifications smp rcvPrivateKey rcvId
 
-disableQueuesNtfs :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
-disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNtfs
+type DisableQueueNtfReq = (NtfSubscription, RcvQueue)
+
+disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
+disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
+  where
+    disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
+    disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
+    queueCreds :: DisableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId)
+    queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvPrivateKey, rcvId)
 
 sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
 sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
-  withSMPClient c rq ("ACK:" <> logSecret msgId) $ \smp ->
+  withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
     ackSMPMessage smp rcvPrivateKey rcvId msgId
   atomically $ releaseGetLock c rq
 
@@ -1640,10 +1679,10 @@ deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c
       pure rs
 
 sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
-sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do
+sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do
   let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
   msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
-  sendOrProxySMPMessage c userId server "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
+  sendOrProxySMPMessage c userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
 
 data ServerQueueInfo = ServerQueueInfo
   { server :: SMPServer,
@@ -1662,7 +1701,7 @@ getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientN
     let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds
     pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info}
   where
-    enc = decodeLatin1 . B64.encode
+    enc = decodeLatin1 . B64.encode . unEntityId
 
 agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
 agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
@@ -1692,6 +1731,27 @@ agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueN
 agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
   withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
 
+type CreateSubNtfReq = (NtfSubscription, ClientNtfCreds)
+
+agentNtfCreateSubscriptions :: AgentClient -> NtfTokenId -> NtfToken -> [CreateSubNtfReq] -> AM' [(CreateSubNtfReq, Either AgentErrorType NtfSubscriptionId)]
+agentNtfCreateSubscriptions c tknId NtfToken {ntfServer, ntfPrivKey} subsCreds = do
+  case L.nonEmpty subsCreds of
+    Just subsCreds' -> do
+      let tSess = (0, ntfServer, Nothing)
+      tryAgentError' (getNtfServerClient c tSess) >>= \case
+        Left e -> pure $ L.toList $ L.map (,Left e) subsCreds'
+        Right ntf -> liftIO $ do
+          logServer' "-->" c ntfServer (bshow (length subsCreds') <> " subscriptions") "SNEW"
+          r <- L.zip subsCreds' <$> ntfCreateSubscriptions ntf ntfPrivKey (L.map toNewSub subsCreds')
+          pure $ L.toList $ L.map agentError r
+          where
+            agentError = second . first $ protocolClientError NTF $ clientServer ntf
+    Nothing -> pure []
+  where
+    toNewSub :: CreateSubNtfReq -> NewNtfEntity 'Subscription
+    toNewSub (NtfSubscription {smpServer}, ClientNtfCreds {ntfPrivateKey, notifierId}) =
+      NewNtfSub tknId (SMPQueueNtf smpServer notifierId) ntfPrivateKey
+
 agentNtfCheckSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM NtfSubStatus
 agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
   withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
@@ -1710,10 +1770,10 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
   rKeys <- xftpRcvKeys n
   (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
   let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
-  logServer "-->" c srv "" "FNEW"
+  logServer "-->" c srv NoEntity "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
   (sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
-  logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId]
+  logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
   pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
 
 agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
@@ -1737,7 +1797,7 @@ xftpRcvKeys n = do
     Just rKeys' -> pure rKeys'
     _ -> throwE $ INTERNAL "non-positive number of recipients"
 
-xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
+xftpRcvIdsKeys :: NonEmpty EntityId -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
 xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
 
 agentCbEncrypt :: SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> AM ByteString
@@ -1793,12 +1853,38 @@ withWork c doWork getWork action =
   withStore' c getWork >>= \case
     Right (Just r) -> action r
     Right Nothing -> noWork
+    -- worker is stopped here (noWork) because the next iteration is likely to produce the same result
     Left e@SEWorkItemError {} -> noWork >> notifyErr (CRITICAL False) e
     Left e -> notifyErr INTERNAL e
   where
     noWork = liftIO $ noWorkToDo doWork
     notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
 
+withWorkItems :: AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError [Either StoreError a])) -> (NonEmpty a -> AM ()) -> AM ()
+withWorkItems c doWork getWork action = do
+  withStore' c getWork >>= \case
+    Right rs -> do
+      let (errs, items) = partitionEithers rs
+      case L.nonEmpty items of
+        Just items' -> action items'
+        Nothing -> do
+          let criticalErr = find workItemError errs
+          forM_ criticalErr $ \err -> do
+            notifyErr (CRITICAL False) err
+            when (all workItemError errs) noWork
+      unless (null errs) $
+        atomically $
+          writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS $ map (\e -> ("", INTERNAL $ show e)) errs)
+    Left e
+      | workItemError e -> noWork >> notifyErr (CRITICAL False) e
+      | otherwise -> notifyErr INTERNAL e
+  where
+    workItemError = \case
+      SEWorkItemError {} -> True
+      _ -> False
+    noWork = liftIO $ noWorkToDo doWork
+    notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
+
 noWorkToDo :: TMVar () -> IO ()
 noWorkToDo = void . atomically . tryTakeTMVar
 {-# INLINE noWorkToDo #-}
@@ -1923,6 +2009,7 @@ withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions)
 storeError :: StoreError -> AgentErrorType
 storeError = \case
   SEConnNotFound -> CONN NOT_FOUND
+  SEUserNotFound -> NO_USER
   SERatchetNotFound -> CONN NOT_FOUND
   SEConnDuplicate -> CONN DUPLICATE
   SEBadConnType CRcv -> CONN SIMPLEX

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

@@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Env.SQLite
   )
 where
 
+import Control.Concurrent (ThreadId)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -76,8 +77,9 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
 import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
+import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
-import UnliftIO (Async, SomeException)
+import UnliftIO (SomeException)
 import UnliftIO.STM
 
 type AM' a = ReaderT Env IO a
@@ -148,6 +150,7 @@ data AgentConfig = AgentConfig
     xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
     ntfCron :: Word16,
+    ntfBatchSize :: Int,
     ntfSubCheckInterval :: NominalDiffTime,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -191,7 +194,7 @@ defaultAgentConfig =
       rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519
       sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
       connIdBytes = 12,
-      tbqSize = 64,
+      tbqSize = 128,
       smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
       ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
       xftpCfg = defaultXFTPClientConfig,
@@ -217,6 +220,7 @@ defaultAgentConfig =
       xftpMaxRecipientsPerRequest = 200,
       deleteErrorCount = 10,
       ntfCron = 20, -- minutes
+      ntfBatchSize = 200,
       ntfSubCheckInterval = nominalDay,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
@@ -252,12 +256,12 @@ createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey k
 
 data NtfSupervisor = NtfSupervisor
   { ntfTkn :: TVar (Maybe NtfToken),
-    ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
+    ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId),
     ntfWorkers :: TMap NtfServer Worker,
     ntfSMPWorkers :: TMap SMPServer Worker
   }
 
-data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
+data NtfSupervisorCommand = NSCCreate | NSCSmpDelete | NSCDeleteSub
   deriving (Show)
 
 newNtfSubSupervisor :: Natural -> IO NtfSupervisor
@@ -312,7 +316,7 @@ mkInternal = INTERNAL . show
 data Worker = Worker
   { workerId :: Int,
     doWork :: TMVar (),
-    action :: TMVar (Maybe (Async ())),
+    action :: TMVar (Maybe (Weak ThreadId)),
     restarts :: TVar RestartCount
   }
 

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -22,22 +23,30 @@ import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.Trans.Except
+import Crypto.Random (ChaChaDRG)
 import Data.Bifunctor (first)
+import Data.Either (partitionEithers)
+import Data.Foldable (foldr')
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
+import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time (UTCTime, addUTCTime, getCurrentTime)
 import Data.Time.Clock (diffUTCTime)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Protocol (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
+import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
+import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfSubscriptionId, NtfTknStatus (..), SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, SMPServer, sameSrvAddr)
+import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
+import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
 import System.Random (randomR)
 import UnliftIO
@@ -48,90 +57,126 @@ runNtfSupervisor :: AgentClient -> AM' ()
 runNtfSupervisor c = do
   ns <- asks ntfSupervisor
   forever $ do
-    cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
-    handleErr connId . agentOperationBracket c AONtfNetwork waitUntilActive $
-      runExceptT (processNtfSub c cmd) >>= \case
-        Left e -> notifyErr connId e
+    cmd <- atomically . readTBQueue $ ntfSubQ ns
+    handleErr . agentOperationBracket c AONtfNetwork waitUntilActive $
+      runExceptT (processNtfCmd c cmd) >>= \case
+        Left e -> notifyErr e
         Right _ -> return ()
   where
-    handleErr :: ConnId -> AM' () -> AM' ()
-    handleErr connId = E.handle $ \(e :: E.SomeException) -> do
+    handleErr :: AM' () -> AM' ()
+    handleErr = E.handle $ \(e :: E.SomeException) -> do
       logError $ "runNtfSupervisor error " <> tshow e
-      notifyErr connId e
-    notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
+      notifyErr e
+    notifyErr e = notifyInternalError' c $ "runNtfSupervisor error " <> show e
 
-processNtfSub :: AgentClient -> (ConnId, NtfSupervisorCommand) -> AM ()
-processNtfSub c (connId, cmd) = do
-  logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
+partitionErrs :: (a -> ConnId) -> [a] -> [Either AgentErrorType b] -> ([(ConnId, AgentErrorType)], [b])
+partitionErrs f xs = partitionEithers . zipWith (\x -> first (f x,)) xs
+{-# INLINE partitionErrs #-}
+
+ntfSubConnId :: NtfSubscription -> ConnId
+ntfSubConnId NtfSubscription {connId} = connId
+
+processNtfCmd :: AgentClient -> (NtfSupervisorCommand, NonEmpty ConnId) -> AM ()
+processNtfCmd c (cmd, connIds) = do
+  logInfo $ "processNtfCmd - cmd = " <> tshow cmd
+  let connIds' = L.toList connIds
   case cmd of
     NSCCreate -> do
-      (a, RcvQueue {userId, server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
-        a <- liftIO $ getNtfSubscription db connId
-        q <- ExceptT $ getPrimaryRcvQueue db connId
-        pure (a, q)
-      logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
-      case a of
-        Nothing -> do
+      (cErrs, rqSubActions) <- lift $ partitionErrs id connIds' <$> withStoreBatch c (\db -> map (getQueueSub db) connIds')
+      notifyErrs c cErrs
+      logInfo $ "processNtfCmd, NSCCreate - length rqSubs = " <> tshow (length rqSubActions)
+      let (ns, rs, css, cns) = partitionQueueSubActions rqSubActions
+      createNewSubs ns
+      resetSubs rs
+      lift $ do
+        mapM_ (getNtfSMPWorker True c) (S.fromList css)
+        mapM_ (getNtfNTFWorker True c) (S.fromList cns)
+      where
+        getQueueSub ::
+          DB.Connection ->
+          ConnId ->
+          IO (Either AgentErrorType (RcvQueue, Maybe NtfSupervisorSub))
+        getQueueSub db connId = fmap (first storeError) $ runExceptT $ do
+          rq <- ExceptT $ getPrimaryRcvQueue db connId
+          sub <- liftIO $ getNtfSubscription db connId
+          pure (rq, sub)
+        createNewSubs :: [RcvQueue] -> AM ()
+        createNewSubs rqs = do
           withTokenServer $ \ntfServer -> do
-            case clientNtfCreds of
-              Just ClientNtfCreds {notifierId} -> do
-                let newSub = newNtfSubscription userId connId smpServer (Just notifierId) ntfServer NASKey
-                withStore c $ \db -> createNtfSubscription db newSub $ NSANtf NSACreate
-                lift . void $ getNtfNTFWorker True c ntfServer
-              Nothing -> do
-                let newSub = newNtfSubscription userId connId smpServer Nothing ntfServer NASNew
-                withStore c $ \db -> createNtfSubscription db newSub $ NSASMP NSASmpKey
-                lift . void $ getNtfSMPWorker True c smpServer
-        (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
-          case (clientNtfCreds, ntfQueueId) of
-            (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
-              | sameSrvAddr smpServer smpServer' && notifierId == ntfQueueId' -> create
-              | otherwise -> rotate
-            (Nothing, Nothing) -> create
-            _ -> rotate
+            let newSubs = map (rqToNewSub ntfServer) rqs
+            (cErrs, _) <- lift $ partitionErrs ntfSubConnId newSubs <$> withStoreBatch c (\db -> map (storeNewSub db) newSubs)
+            notifyErrs c cErrs
+            kickSMPWorkers rqs
           where
-            create :: AM ()
-            create = case action_ of
-              -- action was set to NULL after worker internal error
-              Nothing -> resetSubscription
-              Just (action, _)
-                -- subscription was marked for deletion / is being deleted
-                | isDeleteNtfSubAction action -> do
-                    if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
-                      then resetSubscription
-                      else withTokenServer $ \ntfServer -> do
-                        withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NSANtf NSACreate)
-                        lift . void $ getNtfNTFWorker True c ntfServer
-                | otherwise -> case action of
-                    NSANtf _ -> lift . void $ getNtfNTFWorker True c subNtfServer
-                    NSASMP _ -> lift . void $ getNtfSMPWorker True c smpServer
-            rotate :: AM ()
-            rotate = do
-              withStore' c $ \db -> supervisorUpdateNtfSub db sub (NSANtf NSARotate)
-              lift . void $ getNtfNTFWorker True c subNtfServer
-            resetSubscription :: AM ()
-            resetSubscription =
-              withTokenServer $ \ntfServer -> do
-                let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
-                withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NSASMP NSASmpKey)
-                lift . void $ getNtfSMPWorker True c smpServer
-    NSCDelete -> do
-      sub_ <- withStore' c $ \db -> do
-        supervisorUpdateNtfAction db connId (NSANtf NSADelete)
-        getNtfSubscription db connId
-      logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
-      case sub_ of
-        (Just (NtfSubscription {ntfServer}, _)) -> lift . void $ getNtfNTFWorker True c ntfServer
-        _ -> pure () -- err "NSCDelete - no subscription"
+            rqToNewSub :: NtfServer -> RcvQueue -> NtfSubscription
+            rqToNewSub ntfServer RcvQueue {userId, connId, server} = newNtfSubscription userId connId server Nothing ntfServer NASNew
+            storeNewSub :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType ())
+            storeNewSub db sub = first storeError <$> createNtfSubscription db sub (NSASMP NSASmpKey)
+        resetSubs :: [(RcvQueue, NtfSubscription)] -> AM ()
+        resetSubs rqSubs = do
+          withTokenServer $ \ntfServer -> do
+            let subsToReset = map (toResetSub ntfServer) rqSubs
+            (cErrs, _) <- lift $ partitionErrs ntfSubConnId subsToReset <$> withStoreBatch' c (\db -> map (storeResetSub db) subsToReset)
+            notifyErrs c cErrs
+            let rqs = map fst rqSubs
+            kickSMPWorkers rqs
+          where
+            toResetSub :: NtfServer -> (RcvQueue, NtfSubscription) -> NtfSubscription
+            toResetSub ntfServer (rq, sub) =
+              let RcvQueue {server = smpServer} = rq
+               in sub {smpServer, ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
+            storeResetSub :: DB.Connection -> NtfSubscription -> IO ()
+            storeResetSub db sub = supervisorUpdateNtfSub db sub (NSASMP NSASmpKey)
+        partitionQueueSubActions ::
+          [(RcvQueue, Maybe NtfSupervisorSub)] ->
+          ( [RcvQueue], -- new subs
+            [(RcvQueue, NtfSubscription)], -- reset subs
+            [SMPServer], -- continue work (SMP)
+            [NtfServer] -- continue work (Ntf)
+          )
+        partitionQueueSubActions = foldr' decideSubWork ([], [], [], [])
+          where
+            -- sub = Nothing, needs to be created
+            decideSubWork (rq, Nothing) (ns, rs, css, cns) = (rq : ns, rs, css, cns)
+            decideSubWork (rq, Just (sub, subAction_)) (ns, rs, css, cns) =
+              case (clientNtfCreds rq, ntfQueueId sub) of
+                -- notifier ID created on SMP server (on ntf server subscription can be registered or not yet),
+                -- need to clarify action
+                (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
+                  | sameSrvAddr (qServer rq) subSMPServer && notifierId == ntfQueueId' -> contOrReset
+                  | otherwise -> reset
+                (Nothing, Nothing) -> contOrReset
+                _ -> reset
+              where
+                NtfSubscription {ntfServer = subNtfServer, smpServer = subSMPServer} = sub
+                contOrReset = case subAction_ of
+                  -- action was set to NULL after worker internal error
+                  Nothing -> reset
+                  Just (action, _)
+                    -- subscription was marked for deletion / is being deleted
+                    | isDeleteNtfSubAction action -> reset
+                    -- continue work on subscription (e.g. supervisor was repeatedly tasked with creating a subscription)
+                    | otherwise -> case action of
+                        NSASMP _ -> (ns, rs, qServer rq : css, cns)
+                        NSANtf _ -> (ns, rs, css, subNtfServer : cns)
+                reset = (ns, (rq, sub) : rs, css, cns)
     NSCSmpDelete -> do
-      withStore' c (`getPrimaryRcvQueue` connId) >>= \case
-        Right rq@RcvQueue {server = smpServer} -> do
-          logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
-          withStore' c $ \db -> supervisorUpdateNtfAction db connId (NSASMP NSASmpDelete)
-          lift . void $ getNtfSMPWorker True c smpServer
-        _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    NSCNtfWorker ntfServer -> lift . void $ getNtfNTFWorker True c ntfServer
-    NSCNtfSMPWorker smpServer -> lift . void $ getNtfSMPWorker True c smpServer
+      (cErrs, rqs) <- lift $ partitionErrs id connIds' <$> withStoreBatch c (\db -> map (getQueue db) connIds')
+      logInfo $ "processNtfCmd, NSCSmpDelete - length rqs = " <> tshow (length rqs)
+      (cErrs', _) <- lift $ partitionErrs qConnId rqs <$> withStoreBatch' c (\db -> map (updateAction db) rqs)
+      notifyErrs c (cErrs <> cErrs')
+      kickSMPWorkers rqs
+      where
+        getQueue :: DB.Connection -> ConnId -> IO (Either AgentErrorType RcvQueue)
+        getQueue db connId = first storeError <$> getPrimaryRcvQueue db connId
+        updateAction :: DB.Connection -> RcvQueue -> IO ()
+        updateAction db rq = supervisorUpdateNtfAction db (qConnId rq) (NSASMP NSASmpDelete)
+    NSCDeleteSub -> void $ lift $ withStoreBatch' c $ \db -> map (deleteNtfSubscription' db) connIds'
+  where
+    kickSMPWorkers :: [RcvQueue] -> AM ()
+    kickSMPWorkers rqs = do
+      let smpServers = S.fromList $ map qServer rqs
+      lift $ mapM_ (getNtfSMPWorker True c) smpServers
 
 getNtfNTFWorker :: Bool -> AgentClient -> NtfServer -> AM' Worker
 getNtfNTFWorker hasWork c server = do
@@ -153,18 +198,73 @@ runNtfWorker c srv Worker {doWork} =
     ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
   where
     runNtfOperation :: AM ()
-    runNtfOperation =
-      withWork c doWork (`getNextNtfSubNTFAction` srv) $
-        \nextSub@(NtfSubscription {connId}, _, _) -> do
+    runNtfOperation = do
+      ntfBatchSize <- asks $ ntfBatchSize . config
+      withWorkItems c doWork (\db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
+        logInfo $ "runNtfWorker - length nextSubs = " <> tshow (length nextSubs)
+        let (creates, checks, deletes, rotates) = splitActions nextSubs
+        retrySubActions c creates createSubs
+        -- retrySubActions c checks checkSubs
+        -- retrySubActions c deletes deleteSubs
+        -- retrySubActions c rotates rotateSubs
+        pure ()
+    splitActions :: NonEmpty (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> ([NtfSubscription], [NtfSubscription], [NtfSubscription], [NtfSubscription])
+    splitActions = foldr addAction ([], [], [], [])
+      where
+        addAction action (creates, checks, deletes, rotates) = case action of
+          (sub, NSACreate, _) -> (sub : creates, checks, deletes, rotates)
+          (sub, NSACheck, _) -> (creates, sub : checks, deletes, rotates)
+          (sub, NSADelete, _) -> (creates, checks, sub : deletes, rotates)
+          (sub, NSARotate, _) -> (creates, checks, deletes, sub : rotates)
+    createSubs :: [NtfSubscription] -> AM' [NtfSubscription]
+    createSubs ntfSubs =
+      getNtfToken >>= \case
+        Just tkn@NtfToken {ntfServer, ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
+          subsRqs_ <- zip ntfSubs <$> withStoreBatch c (\db -> map (getQueue db) ntfSubs)
+          let (errs1, subsCreds) = splitSubs subsRqs_
+          -- todo incNtfServerStat ntfCreateAttempts
+          rs <- agentNtfCreateSubscriptions c tknId tkn subsCreds
+          let (subsCreds', errs2, successes) = splitResults rs
+              ntfSubs' = map fst subsCreds'
+              errs2' = map (first (ntfSubConnId . fst)) errs2
+              nSubIds = map (first fst) successes
+          -- todo incNtfServerStat ntfCreated
+          ts <- liftIO getCurrentTime
+          let checkTs = addUTCTime 30 ts
+          (errs3, _) <- partitionErrs (ntfSubConnId . fst) nSubIds <$> withStoreBatch' c (\db -> map (updateSubNSACheck db checkTs) nSubIds)
+          workerErrors c $ errs1 <> errs2' <> errs3
+          pure ntfSubs'
+        _ -> do
+          let errs = map (\sub -> (ntfSubConnId sub, INTERNAL "NSACreate - no active token")) ntfSubs
+          workerErrors c errs
+          pure []
+      where
+        getQueue :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType RcvQueue)
+        getQueue db NtfSubscription {connId} = first storeError <$> getPrimaryRcvQueue db connId
+        splitSubs :: [(NtfSubscription, Either AgentErrorType RcvQueue)] -> ([(ConnId, AgentErrorType)], [(NtfSubscription, ClientNtfCreds)])
+        splitSubs = foldr splitSub ([], [])
+          where
+            splitSub (sub, Right RcvQueue {clientNtfCreds = Just creds}) (errs, ss) = (errs, (sub, creds) : ss)
+            splitSub (sub, Right _) (errs, ss) = ((ntfSubConnId sub, INTERNAL "NSACreate - no notifier queue credentials") : errs, ss)
+            splitSub (sub, Left e) (errs, ss) = ((ntfSubConnId sub, e) : errs, ss)
+        updateSubNSACheck :: DB.Connection -> UTCTime -> (NtfSubscription, NtfSubscriptionId) -> IO ()
+        updateSubNSACheck db checkTs (sub, nSubId) = updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NSANtf NSACheck) checkTs
+    -- -------------------- below - old code --------------------
+    runNtfOperation' :: AM ()
+    runNtfOperation' = do
+      ntfBatchSize <- asks $ ntfBatchSize . config
+      withWorkItems c doWork (\db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \case
+        [nextSub@(NtfSubscription {connId}, _, _)] -> do
           logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop -> do
             liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
-            processSub nextSub
+            processSub' nextSub
               `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
-    processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
-    processSub (sub@NtfSubscription {userId, connId, smpServer, ntfSubId}, action, actionTs) = do
+        _ -> pure ()
+    processSub' :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
+    processSub' (sub@NtfSubscription {userId, connId, smpServer, ntfSubId}, action, actionTs) = do
       ts <- liftIO getCurrentTime
       unlessM (lift $ rescheduleAction doWork ts actionTs) $
         case action of
@@ -193,24 +293,24 @@ runNtfWorker c srv Worker {doWork} =
                       NSAuth -> do
                         withStore' c $ \db ->
                           updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NSASMP NSASmpKey) ts
-                        ns <- asks ntfSupervisor
-                        atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+                        lift . void $ getNtfSMPWorker True c smpServer
                       status -> updateSubNextCheck ts status
                     atomically $ incNtfServerStat c userId ntfServer ntfChecked
                   Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
               _ -> workerInternalError c connId "NSACheck - no active token"
+          -- NSADelete and NSARotate are deprecated, but their processing is kept for legacy db records
           NSADelete ->
             deleteNtfSub $ do
               let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
               withStore' c $ \db -> updateNtfSubscription db sub' (NSASMP NSASmpDelete) ts
-              ns <- asks ntfSupervisor
-              atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+              lift . void $ getNtfSMPWorker True c smpServer
           NSARotate ->
             deleteNtfSub $ do
               withStore' c $ \db -> deleteNtfSubscription db connId
               ns <- asks ntfSupervisor
-              atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
+              atomically $ writeTBQueue (ntfSubQ ns) (NSCCreate, [connId]) -- TODO [batch ntf] loop
       where
+        -- deleteNtfSub is only used in NSADelete and NSARotate, so also deprecated
         deleteNtfSub continue = case ntfSubId of
           Just nSubId ->
             lift getNtfToken >>= \case
@@ -231,51 +331,104 @@ runNtfWorker c srv Worker {doWork} =
             updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
 
 runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
-runNtfSMPWorker c srv Worker {doWork} = do
-  env <- ask
-  forever $ do
-    waitForWork doWork
-    ExceptT . liftIO . agentOperationBracket c AONtfNetwork throwWhenInactive $
-      runReaderT (runExceptT runNtfSMPOperation) env
+runNtfSMPWorker c srv Worker {doWork} = forever $ do
+  waitForWork doWork
+  ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfSMPOperation
   where
-    runNtfSMPOperation =
-      withWork c doWork (`getNextNtfSubSMPAction` srv) $
-        \nextSub@(NtfSubscription {connId}, _, _) -> do
-          logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
-          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop -> do
-            liftIO $ waitWhileSuspended c
-            liftIO $ waitForUserNetwork c
-            processSub nextSub
-              `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
-    processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM ()
-    processSub (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
-      ts <- liftIO getCurrentTime
-      unlessM (lift $ rescheduleAction doWork ts actionTs) $
-        case smpAction of
-          NSASmpKey ->
-            lift getNtfToken >>= \case
-              Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
-                rq <- withStore c (`getPrimaryRcvQueue` connId)
-                C.AuthAlg a <- asks (rcvAuthAlg . config)
-                g <- asks random
-                (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g
-                (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
-                (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
-                let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
-                withStore' c $ \db -> do
-                  setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
-                  updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
-                ns <- asks ntfSupervisor
-                atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
-              _ -> workerInternalError c connId "NSASmpKey - no active token"
-          NSASmpDelete -> do
-            -- TODO should we remove it after successful removal from the server?
-            rq_ <- withStore' c $ \db -> do
-              setRcvQueueNtfCreds db connId Nothing
-              getPrimaryRcvQueue db connId
-            mapM_ (disableQueueNotifications c) rq_
-            withStore' c $ \db -> deleteNtfSubscription db connId
+    runNtfSMPOperation :: AM ()
+    runNtfSMPOperation = do
+      ntfBatchSize <- asks $ ntfBatchSize . config
+      withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
+        logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
+        let (creates, deletes) = splitActions nextSubs
+        retrySubActions c creates createNotifierKeys
+        retrySubActions c deletes deleteNotifierKeys
+    splitActions :: NonEmpty (NtfSubSMPAction, NtfSubscription) -> ([NtfSubscription], [NtfSubscription])
+    splitActions = foldr addAction ([], [])
+      where
+        addAction action (creates, deletes) = case action of
+          (NSASmpKey, sub) -> (sub : creates, deletes)
+          (NSASmpDelete, sub) -> (creates, sub : deletes)
+    createNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
+    createNotifierKeys ntfSubs =
+      getNtfToken >>= \case
+        Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
+          (errs1, subRqKeys) <- prepareQueueSmpKey ntfSubs
+          rs <- enableQueuesNtfs c subRqKeys
+          let (subRqKeys', errs2, successes) = splitResults rs
+              ntfSubs' = map eqnrNtfSub subRqKeys'
+              errs2' = map (first (qConnId . eqnrRq)) errs2
+          ts <- liftIO getCurrentTime
+          (errs3, srvs) <- partitionErrs (qConnId . eqnrRq . fst) successes <$> withStoreBatch' c (\db -> map (storeNtfSubCreds db ts) successes)
+          mapM_ (getNtfNTFWorker True c) $ S.fromList srvs
+          workerErrors c $ errs1 <> errs2' <> errs3
+          pure ntfSubs'
+        _ -> do
+          let errs = map (\sub -> (ntfSubConnId sub, INTERNAL "NSASmpKey - no active token")) ntfSubs
+          workerErrors c errs
+          pure []
+      where
+        prepareQueueSmpKey :: [NtfSubscription] -> AM' ([(ConnId, AgentErrorType)], [EnableQueueNtfReq])
+        prepareQueueSmpKey subs = do
+          alg <- asks (rcvAuthAlg . config)
+          g <- asks random
+          partitionErrs ntfSubConnId subs <$> withStoreBatch c (\db -> map (getQueue db alg g) subs)
+          where
+            getQueue :: DB.Connection -> C.AuthAlg -> TVar ChaChaDRG -> NtfSubscription -> IO (Either AgentErrorType EnableQueueNtfReq)
+            getQueue db (C.AuthAlg a) g sub = fmap (first storeError) $ runExceptT $ do
+              rq <- ExceptT $ getPrimaryRcvQueue db (ntfSubConnId sub)
+              authKeyPair <- atomically $ C.generateAuthKeyPair a g
+              rcvNtfKeyPair <- atomically $ C.generateKeyPair g
+              pure (EnableQueueNtfReq sub rq authKeyPair rcvNtfKeyPair)
+        storeNtfSubCreds :: DB.Connection -> UTCTime -> (EnableQueueNtfReq, (SMP.NotifierId, SMP.RcvNtfPublicDhKey)) -> IO NtfServer
+        storeNtfSubCreds db ts (EnableQueueNtfReq {eqnrNtfSub, eqnrAuthKeyPair = (ntfPublicKey, ntfPrivateKey), eqnrRcvKeyPair = (_, pk)}, (notifierId, srvPubDhKey)) = do
+          let NtfSubscription {ntfServer} = eqnrNtfSub
+              rcvNtfDhSecret = C.dh' srvPubDhKey pk
+          setRcvQueueNtfCreds db (ntfSubConnId eqnrNtfSub) $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
+          updateNtfSubscription db eqnrNtfSub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
+          pure ntfServer
+    deleteNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
+    deleteNotifierKeys ntfSubs = do
+      (errs1, subRqs) <- partitionErrs ntfSubConnId ntfSubs <$> withStoreBatch c (\db -> map (resetCredsGetQueue db) ntfSubs)
+      rs <- disableQueuesNtfs c subRqs
+      let (subRqs', errs2, successes) = splitResults rs
+          ntfSubs' = map fst subRqs'
+          errs2' = map (first (qConnId . snd)) errs2
+          disabledRqs = map (snd . fst) successes
+      (errs3, _) <- partitionErrs qConnId disabledRqs <$> withStoreBatch' c (\db -> map (deleteSub db) disabledRqs)
+      workerErrors c $ errs1 <> errs2' <> errs3
+      pure ntfSubs'
+      where
+        resetCredsGetQueue :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType DisableQueueNtfReq)
+        resetCredsGetQueue db sub@NtfSubscription {connId} = fmap (first storeError) $ runExceptT $ do
+          liftIO $ setRcvQueueNtfCreds db connId Nothing
+          rq <- ExceptT $ getPrimaryRcvQueue db connId
+          pure (sub, rq)
+        deleteSub :: DB.Connection -> RcvQueue -> IO ()
+        deleteSub db rq = deleteNtfSubscription db (qConnId rq)
+
+retrySubActions :: AgentClient -> [NtfSubscription] -> ([NtfSubscription] -> AM' [NtfSubscription]) -> AM ()
+retrySubActions c subs action = do
+  v <- newTVarIO subs
+  ri <- asks $ reconnectInterval . config
+  withRetryInterval ri $ \_ loop -> do
+    liftIO $ waitWhileSuspended c
+    liftIO $ waitForUserNetwork c
+    subs' <- readTVarIO v
+    retrySubs <- lift $ action subs'
+    unless (null retrySubs) $ do
+      atomically $ writeTVar v retrySubs
+      retryNetworkLoop c loop
+
+--                                                (temporary errs, other errs, successes)
+splitResults :: [(a, Either AgentErrorType r)] -> ([a], [(a, AgentErrorType)], [(a, r)])
+splitResults = foldr' addRes ([], [], [])
+  where
+    addRes (a, r_) (as, errs, rs) = case r_ of
+      Right r -> (as, errs, (a, r) : rs)
+      Left e
+        | temporaryOrHostError e -> (a : as, errs, rs)
+        | otherwise -> (as, (a, e) : errs, rs)
 
 rescheduleAction :: TMVar () -> UTCTime -> UTCTime -> AM' Bool
 rescheduleAction doWork ts actionTs
@@ -290,16 +443,22 @@ rescheduleAction doWork ts actionTs
 retryOnError :: AgentClient -> Text -> AM () -> (AgentErrorType -> AM ()) -> AgentErrorType -> AM ()
 retryOnError c name loop done e = do
   logError $ name <> " error: " <> tshow e
-  case e of
-    BROKER _ NETWORK -> retryLoop
-    BROKER _ TIMEOUT -> retryLoop
-    _ -> done e
-  where
-    retryLoop = do
-      atomically $ endAgentOperation c AONtfNetwork
-      liftIO $ throwWhenInactive c
-      atomically $ beginAgentOperation c AONtfNetwork
-      loop
+  if temporaryOrHostError e
+    then retryNetworkLoop c loop
+    else done e
+
+retryNetworkLoop :: AgentClient -> AM () -> AM ()
+retryNetworkLoop c loop = do
+  atomically $ endAgentOperation c AONtfNetwork
+  liftIO $ throwWhenInactive c
+  atomically $ beginAgentOperation c AONtfNetwork
+  loop
+
+workerErrors :: AgentClient -> [(ConnId, AgentErrorType)] -> AM' ()
+workerErrors c connErrs =
+  unless (null connErrs) $ do
+    void $ withStoreBatch' c (\db -> map (setNullNtfSubscriptionAction db . fst) connErrs)
+    notifyErrs c connErrs
 
 workerInternalError :: AgentClient -> ConnId -> String -> AM ()
 workerInternalError c connId internalErrStr = do
@@ -311,6 +470,14 @@ notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m ()
 notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
 {-# INLINE notifyInternalError #-}
 
+notifyInternalError' :: MonadIO m => AgentClient -> String -> m ()
+notifyInternalError' AgentClient {subQ} internalErrStr = atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
+{-# INLINE notifyInternalError' #-}
+
+notifyErrs :: MonadIO m => AgentClient -> [(ConnId, AgentErrorType)] -> m ()
+notifyErrs AgentClient {subQ} connErrs = unless (null connErrs) $ atomically $ writeTBQueue subQ ("", "", AEvt SAENone $ ERRS connErrs)
+{-# INLINE notifyErrs #-}
+
 getNtfToken :: AM' (Maybe NtfToken)
 getNtfToken = do
   tkn <- asks $ ntfTkn . ntfSupervisor
@@ -322,7 +489,7 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
 nsRemoveNtfToken :: NtfSupervisor -> STM ()
 nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
 
-sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
+sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
 sendNtfSubCommand ns cmd = do
   tkn <- readTVar (ntfTkn ns)
   when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd

src/Simplex/Messaging/Agent/Protocol.hs

@@ -51,6 +51,7 @@ module Simplex.Messaging.Agent.Protocol
     -- * SMP agent protocol types
     ConnInfo,
     SndQueueSecured,
+    AEntityId,
     ACommand (..),
     AEvent (..),
     AEvt (..),
@@ -190,7 +191,6 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( AProtocolType,
     BrokerErrorType (..),
-    EntityId,
     ErrorType,
     MsgBody,
     MsgFlags,
@@ -277,20 +277,22 @@ supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPA
 e2eEncConnInfoLength :: VersionSMPA -> PQSupport -> Int
 e2eEncConnInfoLength v = \case
   -- reduced by 3726 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
-  PQSupportOn | v >= pqdrSMPAgentVersion -> 11122
-  _ -> 14848
+  PQSupportOn | v >= pqdrSMPAgentVersion -> 11106
+  _ -> 14832
 
 e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
 e2eEncAgentMsgLength v = \case
   -- reduced by 2222 (the increase of message ratchet header size)
-  PQSupportOn | v >= pqdrSMPAgentVersion -> 13634
-  _ -> 15856
+  PQSupportOn | v >= pqdrSMPAgentVersion -> 13618
+  _ -> 15840
 
 -- | SMP agent event
-type ATransmission = (ACorrId, EntityId, AEvt)
+type ATransmission = (ACorrId, AEntityId, AEvt)
 
 type UserId = Int64
 
+type AEntityId = ByteString
+
 type ACorrId = ByteString
 
 data AEntity = AEConn | AERcvFile | AESndFile | AENone
@@ -342,6 +344,7 @@ data AEvent (e :: AEntity) where
   INFO :: PQSupport -> ConnInfo -> AEvent AEConn
   CON :: PQEncryption -> AEvent AEConn -- notification that connection is established
   END :: AEvent AEConn
+  DELD :: AEvent AEConn
   CONNECT :: AProtocolType -> TransportHost -> AEvent AENone
   DISCONNECT :: AProtocolType -> TransportHost -> AEvent AENone
   DOWN :: SMPServer -> [ConnId] -> AEvent AENone
@@ -363,6 +366,7 @@ data AEvent (e :: AEntity) where
   OK :: AEvent AEConn
   JOINED :: SndQueueSecured -> AEvent AEConn
   ERR :: AgentErrorType -> AEvent AEConn
+  ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
   SUSPENDED :: AEvent AENone
   RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
   RFDONE :: FilePath -> AEvent AERcvFile
@@ -411,6 +415,7 @@ data AEventTag (e :: AEntity) where
   INFO_ :: AEventTag AEConn
   CON_ :: AEventTag AEConn
   END_ :: AEventTag AEConn
+  DELD_ :: AEventTag AEConn
   CONNECT_ :: AEventTag AENone
   DISCONNECT_ :: AEventTag AENone
   DOWN_ :: AEventTag AENone
@@ -432,6 +437,7 @@ data AEventTag (e :: AEntity) where
   OK_ :: AEventTag AEConn
   JOINED_ :: AEventTag AEConn
   ERR_ :: AEventTag AEConn
+  ERRS_ :: AEventTag AENone
   SUSPENDED_ :: AEventTag AENone
   -- XFTP commands and responses
   RFDONE_ :: AEventTag AERcvFile
@@ -464,6 +470,7 @@ aEventTag = \case
   INFO {} -> INFO_
   CON _ -> CON_
   END -> END_
+  DELD -> DELD_
   CONNECT {} -> CONNECT_
   DISCONNECT {} -> DISCONNECT_
   DOWN {} -> DOWN_
@@ -485,6 +492,7 @@ aEventTag = \case
   OK -> OK_
   JOINED _ -> JOINED_
   ERR _ -> ERR_
+  ERRS _ -> ERRS_
   SUSPENDED -> SUSPENDED_
   RFPROG {} -> RFPROG_
   RFDONE {} -> RFDONE_
@@ -1336,6 +1344,8 @@ data AgentErrorType
     CMD {cmdErr :: CommandErrorType, errContext :: String}
   | -- | connection errors
     CONN {connErr :: ConnectionErrorType}
+  | -- | user not found in database
+    NO_USER
   | -- | SMP protocol errors forwarded to agent clients
     SMP {serverAddress :: String, smpErr :: ErrorType}
   | -- | NTF protocol errors forwarded to agent clients

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

@@ -1,10 +1,12 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -15,6 +17,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
@@ -57,6 +60,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     getDeletedConns,
     getConnData,
     setConnDeleted,
+    setConnUserId,
     setConnAgentVersion,
     setConnPQSupport,
     getDeletedConnIds,
@@ -110,6 +114,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     getSndMsgViaRcpt,
     updateSndMsgRcpt,
     getPendingQueueMsg,
+    getConnectionsForDelivery,
     updatePendingMsgRIState,
     deletePendingMsgs,
     getExpiredSndMessages,
@@ -135,6 +140,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     createCommand,
     getPendingCommandServers,
     getPendingServerCommand,
+    updateCommandServer,
     deleteCommand,
     -- Notification device token persistence
     createNtfToken,
@@ -145,6 +151,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateNtfToken,
     removeNtfToken,
     -- Notification subscription persistence
+    NtfSupervisorSub,
     getNtfSubscription,
     createNtfSubscription,
     supervisorUpdateNtfSub,
@@ -152,9 +159,10 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateNtfSubscription,
     setNullNtfSubscriptionAction,
     deleteNtfSubscription,
-    getNextNtfSubNTFAction,
+    deleteNtfSubscription',
+    getNextNtfSubNTFActions,
     markNtfSubActionNtfFailed_, -- exported for tests
-    getNextNtfSubSMPAction,
+    getNextNtfSubSMPActions,
     markNtfSubActionSMPFailed_, -- exported for tests
     getActiveNtfToken,
     getNtfRcvQueue,
@@ -965,12 +973,12 @@ createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, i
   insertRcvMsgDetails_ db connId rq rcvMsgData
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
 
-updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
-updateSndIds db connId = do
-  (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ db connId
+updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
+updateSndIds db connId = runExceptT $ do
+  (lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId
   let internalId = InternalId $ unId lastInternalId + 1
       internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
-  updateLastIdsSnd_ db connId internalId internalSndId
+  liftIO $ updateLastIdsSnd_ db connId internalId internalSndId
   pure (internalId, internalSndId, prevSndHash)
 
 createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO ()
@@ -1008,6 +1016,10 @@ updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} =
     "UPDATE snd_messages SET rcpt_internal_id = ?, rcpt_status = ? WHERE conn_id = ? AND internal_snd_id = ?"
     (agentMsgId, msgRcptStatus, connId, sndMsgId)
 
+getConnectionsForDelivery :: DB.Connection -> IO [ConnId]
+getConnectionsForDelivery db =
+  map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0"
+
 getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
 getPendingQueueMsg db connId SndQueue {dbQueueId} =
   getWorkItem "message" getMsgId getMsgData markMsgFailed
@@ -1051,17 +1063,26 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
 
 getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
 getWorkItem itemName getId getItem markFailed =
-  runExceptT $ handleErr "getId" getId >>= mapM tryGetItem
+  runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed)
+
+getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a])
+getWorkItems itemName getIds getItem markFailed =
+  runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed)
+
+tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a
+tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e
   where
-    tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwE e
-    mark itemId = handleErr ("markFailed ID " <> bshow itemId) $ markFailed itemId
-    catchStoreErrors = catchAllErrors (SEInternal . bshow)
-    -- Errors caught by this function will suspend worker as if there is no more work,
-    handleErr :: ByteString -> IO a -> ExceptT StoreError IO a
-    handleErr opName action = ExceptT $ first mkError <$> E.try action
-      where
-        mkError :: E.SomeException -> StoreError
-        mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
+    mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId
+
+catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
+catchStoreError = catchAllErrors (SEInternal . bshow)
+
+-- Errors caught by this function will suspend worker as if there is no more work,
+handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a
+handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action
+  where
+    mkError :: E.SomeException -> StoreError
+    mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
 
 updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO ()
 updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} =
@@ -1317,38 +1338,39 @@ getPendingCommandServers db connId = do
   where
     smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
 
-getPendingServerCommand :: DB.Connection -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
-getPendingServerCommand db srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
+getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
+getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
   where
     getCmdId :: IO (Maybe Int64)
     getCmdId =
       maybeFirstRow fromOnly $ case srv_ of
         Nothing ->
-          DB.query_
+          DB.query
             db
             [sql|
               SELECT command_id FROM commands
-              WHERE host IS NULL AND port IS NULL AND failed = 0
+              WHERE conn_id = ? AND host IS NULL AND port IS NULL AND failed = 0
               ORDER BY created_at ASC, command_id ASC
               LIMIT 1
             |]
+            (Only connId)
         Just (SMPServer host port _) ->
           DB.query
             db
             [sql|
               SELECT command_id FROM commands
-              WHERE host = ? AND port = ? AND failed = 0
+              WHERE conn_id = ? AND host = ? AND port = ? AND failed = 0
               ORDER BY created_at ASC, command_id ASC
               LIMIT 1
             |]
-            (host, port)
+            (connId, host, port)
     getCommand :: Int64 -> IO (Either StoreError PendingCommand)
     getCommand cmdId =
       firstRow pendingCommand err $
         DB.query
           db
           [sql|
-            SELECT c.corr_id, cs.user_id, c.conn_id, c.command
+            SELECT c.corr_id, cs.user_id, c.command
             FROM commands c
             JOIN connections cs USING (conn_id)
             WHERE c.command_id = ?
@@ -1356,9 +1378,22 @@ getPendingServerCommand db srv_ = getWorkItem "command" getCmdId getCommand mark
           (Only cmdId)
       where
         err = SEInternal $ "command  " <> bshow cmdId <> " returned []"
-        pendingCommand (corrId, userId, connId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
+        pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
     markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId)
 
+updateCommandServer :: DB.Connection -> AsyncCmdId -> SMPServer -> IO (Either StoreError ())
+updateCommandServer db cmdId srv@(SMPServer host port _) = runExceptT $ do
+  serverKeyHash_ <- ExceptT $ getServerKeyHash_ db srv
+  liftIO $
+    DB.execute
+      db
+      [sql|
+        UPDATE commands
+        SET host = ?, port = ?, server_key_hash = ?
+        WHERE command_id = ?
+      |]
+      (host, port, serverKeyHash_, cmdId)
+
 deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
 deleteCommand db cmdId =
   DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
@@ -1451,7 +1486,9 @@ removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer
     |]
     (provider, token, host, port)
 
-getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe (NtfSubscription, Maybe (NtfSubAction, NtfActionTs)))
+type NtfSupervisorSub = (NtfSubscription, Maybe (NtfSubAction, NtfActionTs))
+
+getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe NtfSupervisorSub)
 getNtfSubscription db connId =
   maybeFirstRow ntfSubscription $
     DB.query
@@ -1467,7 +1504,7 @@ getNtfSubscription db connId =
       |]
       (Only connId)
   where
-    ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash ) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
+    ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
       let smpServer = SMPServer smpHost smpPort smpKeyHash
           ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
           action = case (ntfAction_, smpAction_, actionTs_) of
@@ -1497,16 +1534,19 @@ createNtfSubscription db ntfSubscription action = runExceptT $ do
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
 supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
-supervisorUpdateNtfSub db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
+supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
   ts <- getCurrentTime
   DB.execute
     db
     [sql|
       UPDATE ntf_subscriptions
-      SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
+      SET smp_host = ?, smp_port = ?, smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?,
+          ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
       WHERE conn_id = ?
     |]
-    ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId))
+    ( (smpHost, smpPort, ntfQueueId, ntfHost, ntfPort, ntfSubId)
+        :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId)
+    )
   where
     (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
 
@@ -1581,16 +1621,20 @@ deleteNtfSubscription db connId = do
             WHERE conn_id = ?
           |]
           (Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId)
-      else DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
+      else deleteNtfSubscription' db connId
 
-getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs)))
-getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
-  getWorkItem "ntf NTF" getNtfConnId getNtfSubAction (markNtfSubActionNtfFailed_ db)
+deleteNtfSubscription' :: DB.Connection -> ConnId -> IO ()
+deleteNtfSubscription' db connId = do
+  DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
+
+getNextNtfSubNTFActions :: DB.Connection -> NtfServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubscription, NtfSubNTFAction, NtfActionTs)])
+getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize =
+  getWorkItems "ntf NTF" getNtfConnIds getNtfSubAction (markNtfSubActionNtfFailed_ db)
   where
-    getNtfConnId :: IO (Maybe ConnId)
-    getNtfConnId =
-      maybeFirstRow fromOnly $
-        DB.query
+    getNtfConnIds :: IO [ConnId]
+    getNtfConnIds =
+      map fromOnly
+        <$> DB.query
           db
           [sql|
             SELECT conn_id
@@ -1598,9 +1642,9 @@ getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
             WHERE ntf_host = ? AND ntf_port = ? AND ntf_sub_action IS NOT NULL
               AND (ntf_failed = 0 OR updated_by_supervisor = 1)
             ORDER BY ntf_sub_action_ts ASC
-            LIMIT 1
+            LIMIT ?
           |]
-          (ntfHost, ntfPort)
+          (ntfHost, ntfPort, ntfBatchSize)
     getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubNTFAction, NtfActionTs))
     getNtfSubAction connId = do
       markUpdatedByWorker db connId
@@ -1627,14 +1671,14 @@ markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO ()
 markNtfSubActionNtfFailed_ db connId =
   DB.execute db "UPDATE ntf_subscriptions SET ntf_failed = 1 where conn_id = ?" (Only connId)
 
-getNextNtfSubSMPAction :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubSMPAction, NtfActionTs)))
-getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
-  getWorkItem "ntf SMP" getNtfConnId getNtfSubAction (markNtfSubActionSMPFailed_ db)
+getNextNtfSubSMPActions :: DB.Connection -> SMPServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubSMPAction, NtfSubscription)])
+getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize =
+  getWorkItems "ntf SMP" getNtfConnIds getNtfSubAction (markNtfSubActionSMPFailed_ db)
   where
-    getNtfConnId :: IO (Maybe ConnId)
-    getNtfConnId =
-      maybeFirstRow fromOnly $
-        DB.query
+    getNtfConnIds :: IO [ConnId]
+    getNtfConnIds =
+      map fromOnly
+        <$> DB.query
           db
           [sql|
             SELECT conn_id
@@ -1642,10 +1686,10 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
             WHERE smp_host = ? AND smp_port = ? AND ntf_sub_smp_action IS NOT NULL AND ntf_sub_action_ts IS NOT NULL
               AND (smp_failed = 0 OR updated_by_supervisor = 1)
             ORDER BY ntf_sub_action_ts ASC
-            LIMIT 1
+            LIMIT ?
           |]
-          (smpHost, smpPort)
-    getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubSMPAction, NtfActionTs))
+          (smpHost, smpPort, ntfBatchSize)
+    getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubSMPAction, NtfSubscription))
     getNtfSubAction connId = do
       markUpdatedByWorker db connId
       firstRow ntfSubAction err $
@@ -1653,7 +1697,7 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
           db
           [sql|
             SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
-              ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
+              ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_smp_action
             FROM ntf_subscriptions ns
             JOIN connections c USING (conn_id)
             JOIN ntf_servers s USING (ntf_host, ntf_port)
@@ -1662,10 +1706,10 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
           (Only connId)
       where
         err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
-        ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
+        ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, action) =
           let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
               ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
-           in (ntfSubscription, action, actionTs)
+           in (action, ntfSubscription)
 
 markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO ()
 markNtfSubActionSMPFailed_ db connId =
@@ -1793,6 +1837,14 @@ instance ToField (Version v) where toField (Version v) = toField v
 
 instance FromField (Version v) where fromField f = Version <$> fromField f
 
+deriving newtype instance ToField EntityId
+
+deriving newtype instance FromField EntityId
+
+deriving newtype instance ToField ChunkReplicaId
+
+deriving newtype instance FromField ChunkReplicaId
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -1909,9 +1961,11 @@ newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
 
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getConn = getAnyConn False
+{-# INLINE getConn #-}
 
 getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getDeletedConn = getAnyConn True
+{-# INLINE getDeletedConn #-}
 
 getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getAnyConn deleted' dbConn connId =
@@ -1932,9 +1986,11 @@ getAnyConn deleted' dbConn connId =
 
 getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getConns = getAnyConns_ False
+{-# INLINE getConns #-}
 
 getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getDeletedConns = getAnyConns_ True
+{-# INLINE getDeletedConns #-}
 
 getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
@@ -1967,6 +2023,10 @@ setConnDeleted db waitDelivery connId
   | otherwise =
       DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
 
+setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO ()
+setConnUserId db oldUserId connId newUserId =
+  DB.execute db "UPDATE connections SET user_id = ? WHERE conn_id = ? and user_id = ?" (newUserId, connId, oldUserId)
+
 setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO ()
 setConnAgentVersion db connId aVersion =
   DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId)
@@ -2179,9 +2239,9 @@ updateRcvMsgHash db connId sndMsgId internalRcvId internalHash =
 
 -- * updateSndIds helpers
 
-retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
+retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
 retrieveLastIdsAndHashSnd_ dbConn connId = do
-  [(lastInternalId, lastInternalSndId, lastSndHash)] <-
+  firstRow id SEConnNotFound $
     DB.queryNamed
       dbConn
       [sql|
@@ -2190,7 +2250,6 @@ retrieveLastIdsAndHashSnd_ dbConn connId = do
         WHERE conn_id = :conn_id;
       |]
       [":conn_id" := connId]
-  return (lastInternalId, lastInternalSndId, lastSndHash)
 
 updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO ()
 updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
@@ -2486,7 +2545,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO ()
 deleteRcvFile' db rcvFileId =
   DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId)
 
-getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool)))
+getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool, Maybe RcvFileId)))
 getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
   getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
   where
@@ -2510,7 +2569,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
             LIMIT 1
           |]
           (host, port, keyHash, RFSReceiving, cutoffTs)
-    getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool))
+    getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool, Maybe RcvFileId))
     getChunkData (rcvFileChunkReplicaId, _fileId) =
       firstRow toChunk SEFileNotFound $
         DB.query
@@ -2519,7 +2578,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
             SELECT
               f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
               r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries,
-              f.approved_relays
+              f.approved_relays, f.redirect_entity_id
             FROM rcv_file_chunk_replicas r
             JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
             JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
@@ -2528,8 +2587,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
           |]
           (Only rcvFileChunkReplicaId)
       where
-        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool)
-        toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) =
+        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId)
+        toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) =
           ( RcvFileChunk
               { rcvFileId,
                 rcvFileEntityId,
@@ -2542,7 +2601,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
                 chunkTmpPath,
                 replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
               },
-            approvedRelays
+            approvedRelays,
+            redirectEntityId_
           )
 
 getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile))

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -20,15 +21,19 @@ where
 
 import Control.Concurrent.STM
 import Control.Monad (when)
+import Control.Exception
 import qualified Data.Aeson.TH as J
 import Data.Int (Int64)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
 import Data.Time (diffUTCTime, getCurrentTime)
 import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow)
 import qualified Database.SQLite.Simple as SQL
 import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (diffToMilliseconds)
+import Simplex.Messaging.Util (diffToMilliseconds, tshow)
 
 data Connection = Connection
   { conn :: SQL.Connection,
@@ -38,27 +43,35 @@ data Connection = Connection
 data SlowQueryStats = SlowQueryStats
   { count :: Int64,
     timeMax :: Int64,
-    timeAvg :: Int64
+    timeAvg :: Int64,
+    errs :: Map Text Int
   }
   deriving (Show)
 
 timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a
 timeIt slow sql a = do
   t <- getCurrentTime
-  r <- a
+  r <- a `catch` \e -> do
+    atomically $ TM.alter (Just . updateQueryErrors e) sql slow
+    throwIO e
   t' <- getCurrentTime
   let diff = diffToMilliseconds $ diffUTCTime t' t
-  atomically $ when (diff > 5) $ TM.alter (updateQueryStats diff) sql slow
+  when (diff > 1) $ atomically $ TM.alter (updateQueryStats diff) sql slow
   pure r
   where
+    updateQueryErrors :: SomeException -> Maybe SlowQueryStats -> SlowQueryStats
+    updateQueryErrors e Nothing = SlowQueryStats 0 0 0 $ M.singleton (tshow e) 1
+    updateQueryErrors e (Just stats@SlowQueryStats {errs}) =
+      stats {errs = M.alter (Just . maybe 1 (+ 1)) (tshow e) errs}
     updateQueryStats :: Int64 -> Maybe SlowQueryStats -> Maybe SlowQueryStats
-    updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff
-    updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg}) =
+    updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff M.empty
+    updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg, errs}) =
       Just $
         SlowQueryStats
           { count = count + 1,
             timeMax = max timeMax diff,
-            timeAvg = (timeAvg * count + diff) `div` (count + 1)
+            timeAvg = (timeAvg * count + diff) `div` (count + 1),
+            errs
           }
 
 open :: String -> IO Connection

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

@@ -29,7 +29,7 @@ import Control.Monad (forM_, when)
 import qualified Data.Aeson.TH as J
 import Data.List (intercalate, sortOn)
 import Data.List.NonEmpty (NonEmpty)
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing, mapMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1)

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -31,7 +31,7 @@ import Simplex.Messaging.Transport
 
 class Queue q where
   connId' :: q -> ConnId
-  qKey :: q -> (UserId, SMPServer, ConnId)
+  qKey :: q -> (UserId, SMPServer, RecipientId)
 
 -- the fields in this record have the same data with swapped keys for lookup efficiency,
 -- and all methods must maintain this invariant.
@@ -63,7 +63,7 @@ addQueue rq (TRcvQueues qs cs) = do
     addQ = Just . maybe (k :| []) (k <|)
     k = qKey rq
 
--- Save time by aggregating modifyTVar
+-- Save time by aggregating modifyTVar'
 batchAddQueues :: (Foldable t, Queue q) => TRcvQueues q -> t q -> STM ()
 batchAddQueues (TRcvQueues qs cs) rqs = do
   modifyTVar' qs $ \now -> foldl' (\rqs' rq -> M.insert (qKey rq) rq rqs') now rqs
@@ -97,7 +97,7 @@ getDelSessQueues tSess sessId' (TRcvQueues qs cs) = do
     delQ acc@(removed, qs') (sessId, rq)
       | rq `isSession` tSess && sessId == sessId' = (rq : removed, M.delete (qKey rq) qs')
       | otherwise = acc
-    delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, ConnId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, ConnId)))
+    delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId)))
     delConn (removed, cs') rq = M.alterF f cId cs'
       where
         cId = connId rq
@@ -113,7 +113,7 @@ isSession rq (uId, srv, connId_) =
 
 instance Queue RcvQueue where
   connId' = connId
-  qKey rq = (userId rq, server rq, connId rq)
+  qKey rq = (userId rq, server rq, rcvId rq)
 
 instance Queue (SessionId, RcvQueue) where
   connId' = connId . snd

src/Simplex/Messaging/Client.hs

@@ -63,11 +63,13 @@ module Simplex.Messaging.Client
     forwardSMPTransmission,
     getSMPQueueInfo,
     sendProtocolCommand,
+    sendProtocolCommands,
 
     -- * Supporting types and client configuration
     ProtocolClientError (..),
     SMPClientError,
     ProxyClientError (..),
+    Response (..),
     unexpectedResponse,
     ProtocolClientConfig (..),
     NetworkConfig (..),
@@ -80,10 +82,11 @@ module Simplex.Messaging.Client
     defaultSMPClientConfig,
     defaultNetworkConfig,
     transportClientConfig,
+    clientSocksCredentials,
     chooseTransportHost,
-    proxyUsername,
     temporaryClientError,
     smpProxyError,
+    textToHostMode,
     ServerTransmissionBatch,
     ServerTransmission (..),
     ClientCommand,
@@ -114,18 +117,22 @@ import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find)
+import Data.List (find, intercalate)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (catMaybes, fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import Network.Socket (ServiceName)
+import Network.Socks5 (SocksCredentials (..))
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -136,7 +143,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
+import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
@@ -236,6 +243,12 @@ data HostMode
     HMPublic
   deriving (Eq, Show)
 
+textToHostMode :: Text -> Either String HostMode
+textToHostMode = \case
+  "public" -> Right HMPublic
+  "onion" -> Right HMOnionViaSocks
+  s -> Left $ T.unpack $ "Invalid host_mode: " <> s
+
 data SocksMode
   = -- | always use SOCKS proxy when enabled
     SMAlways
@@ -257,7 +270,7 @@ instance StrEncoding SocksMode where
 -- | network configuration for the client
 data NetworkConfig = NetworkConfig
   { -- | use SOCKS5 proxy
-    socksProxy :: Maybe SocksProxy,
+    socksProxy :: Maybe SocksProxyWithAuth,
     -- | when to use SOCKS proxy
     socksMode :: SocksMode,
     -- | determines critera which host is chosen from the list
@@ -288,7 +301,7 @@ data NetworkConfig = NetworkConfig
   }
   deriving (Eq, Show)
 
-data TransportSessionMode = TSMUser | TSMEntity
+data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
   deriving (Eq, Show)
 
 -- SMP proxy mode for sending messages
@@ -338,7 +351,7 @@ defaultNetworkConfig =
       socksMode = SMAlways,
       hostMode = HMOnionViaSocks,
       requiredHostMode = False,
-      sessionMode = TSMUser,
+      sessionMode = TSMSession,
       smpProxyMode = SPMNever,
       smpProxyFallback = SPFAllow,
       tcpConnectTimeout = defaultTcpConnectTimeout,
@@ -355,11 +368,28 @@ transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig
 transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host =
   TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
   where
-    useSocksProxy SMAlways = socksProxy
+    socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
+    useSocksProxy SMAlways = socksProxy'
     useSocksProxy SMOnion = case host of
-      THOnionHost _ -> socksProxy
+      THOnionHost _ -> socksProxy'
       _ -> Nothing
-{-# INLINE transportClientConfig #-}
+
+clientSocksCredentials :: ProtocolTypeI (ProtoType msg) => NetworkConfig -> UTCTime -> TransportSession msg -> Maybe SocksCredentials
+clientSocksCredentials NetworkConfig {socksProxy, sessionMode} proxySessTs (userId, srv, entityId_) = case socksProxy of
+  Just (SocksProxyWithAuth auth _) -> case auth of
+    SocksAuthUsername {username, password} -> Just $ SocksCredentials username password
+    SocksAuthNull -> Nothing
+    SocksIsolateByAuth -> Just $ SocksCredentials sessionUsername ""
+  Nothing -> Nothing
+  where
+    sessionUsername =
+      B64.encode $
+        C.sha256Hash $
+          bshow userId <> case sessionMode of
+            TSMUser -> ""
+            TSMSession -> ":" <> bshow proxySessTs
+            TSMServer -> ":" <> bshow proxySessTs <> "@" <> strEncode srv
+            TSMEntity -> ":" <> bshow proxySessTs <> "@" <> strEncode srv <> maybe "" ("/" <>) entityId_
 
 -- | protocol client configuration.
 data ProtocolClientConfig v = ProtocolClientConfig
@@ -441,15 +471,16 @@ transportSession' = transportSession . client_
 type UserId = Int64
 
 -- | Transport session key - includes entity ID if `sessionMode = TSMEntity`.
-type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
+-- Please note that for SMP connection ID is used as entity ID, not queue ID.
+type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
 
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
+getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -488,9 +519,9 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
     runClient (port', ATransport t) useHost c = do
       cVar <- newEmptyTMVarIO
       let tcConfig = (transportClientConfig networkConfig useHost) {alpn = clientALPN}
-          username = proxyUsername transportSession
+          socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
       tId <-
-        runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
+        runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
           `forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
       c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
       case c_ of
@@ -544,7 +575,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
           if remaining > 1_000_000 -- delay pings only for significant time
             then loop remaining
             else do
-              whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing "" (protocolPing @v @err @msg)
+              whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg)
               -- sendProtocolCommand/getResponse updates counter for each command
               cnt <- readTVarIO timeoutErrorCount
               -- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
@@ -596,10 +627,6 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
 unexpectedResponse :: Show r => r -> ProtocolClientError err
 unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
 
-proxyUsername :: TransportSession msg -> ByteString
-proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
-{-# INLINE proxyUsername #-}
-
 -- | Disconnects client from the server and terminates client threads.
 closeProtocolClient :: ProtocolClient v err msg -> IO ()
 closeProtocolClient = mapM_ (deRefWeak >=> mapM_ killThread) . action
@@ -670,7 +697,7 @@ createSMPQueue ::
   Bool ->
   ExceptT SMPClientError IO QueueIdsKeys
 createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
-  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case
+  sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case
     IDS qik -> pure qik
     r -> throwE $ unexpectedResponse r
 
@@ -689,7 +716,7 @@ subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = d
 subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 subscribeSMPQueues c@ProtocolClient {client_ = PClient {sendPings}} qs = do
   atomically $ writeTVar sendPings True
-  sendProtocolCommands c cs >>= mapM (processSUBResponse c)
+  sendProtocolCommands "subscribeSMPQueues" c cs >>= mapM (processSUBResponse c)
   where
     cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
 
@@ -762,7 +789,7 @@ enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
 
 -- | Enable notifications for the multiple queues for push notifications server.
 enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
-enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
+enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands "enableSMPQueuesNtfs" c cs
   where
     cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
     process (Response _ r) = case r of
@@ -829,7 +856,7 @@ deleteSMPQueues = okSMPCommands DEL
 connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
 connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
   | thVersion (thParams c) >= sendingProxySMPVersion =
-      sendProtocolCommand_ c Nothing tOut Nothing "" (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
+      sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
         PKEY sId vr (chain, key) ->
           case supportedClientSMPRelayVRange `compatibleVersion` vr of
             Nothing -> throwE $ transportErr TEVersion
@@ -931,7 +958,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
   et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
   -- proxy interaction errors are wrapped
   let tOut = Just $ 2 * tcpTimeout
-  tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
+  tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
     Right r -> case r of
       PRES (EncResponse er) -> do
         -- server interaction errors are thrown directly
@@ -967,7 +994,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
   let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
       eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
   -- send
-  sendProtocolCommand_ c (Just nonce) Nothing Nothing "" (Cmd SSender (RFWD eft)) >>= \case
+  sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SSender (RFWD eft)) >>= \case
     RRES (EncFwdResponse efr) -> do
       -- unwrap
       r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
@@ -988,7 +1015,7 @@ okSMPCommand cmd c pKey qId =
     r -> throwE $ unexpectedResponse r
 
 okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
-okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
+okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands "okSMPCommands" c cs
   where
     aCmd = Cmd sParty cmd
     cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
@@ -1005,17 +1032,23 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
 
 -- | Send multiple commands with batching and collect responses
-sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
-sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
+sendProtocolCommands :: forall v err msg. Protocol v err msg => String -> ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
+sendProtocolCommands name c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
   bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
+  let size = intercalate "," $ map (show . batchSize) bs
+  liftIO $ print $ show name <> " length cs = " <> show (length cs) <> " length bs = " <> show (length bs) <> ", size = " <> show size <> "/" <> show blockSize
   validate . concat =<< mapM (sendBatch c) bs
   where
+    batchSize = \case
+      TBTransmissions bytestring _ _ -> B.length bytestring
+      TBTransmission bytestring _ -> B.length bytestring
+      TBError _ _ -> 0
     validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
     validate rs
       | diff == 0 = pure $ L.fromList rs
       | diff > 0 = do
           putStrLn "send error: fewer responses than expected"
-          pure $ L.fromList $ rs <> replicate diff (Response "" $ Left $ PCETransportError TEBadBlock)
+          pure $ L.fromList $ rs <> replicate diff (Response NoEntity $ Left $ PCETransportError TEBadBlock)
       | otherwise = do
           putStrLn "send error: more responses than expected"
           pure $ L.fromList $ take (L.length cs) rs

src/Simplex/Messaging/Client/Agent.hs

@@ -95,6 +95,7 @@ defaultSMPClientAgentConfig =
 data SMPClientAgent = SMPClientAgent
   { agentCfg :: SMPClientAgentConfig,
     active :: TVar Bool,
+    startedAt :: UTCTime,
     msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
     agentQ :: TBQueue SMPClientAgentEvent,
     randomDrg :: TVar ChaChaDRG,
@@ -111,6 +112,7 @@ type OwnServer = Bool
 newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
 newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
   active <- newTVarIO True
+  startedAt <- getCurrentTime
   msgQ <- newTBQueueIO msgQSize
   agentQ <- newTBQueueIO agentQSize
   smpClients <- TM.emptyIO
@@ -123,6 +125,7 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg
     SMPClientAgent
       { agentCfg,
         active,
+        startedAt,
         msgQ,
         agentQ,
         randomDrg,
@@ -194,8 +197,8 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
 
 -- | Run an SMP client for SMPClientVar
 connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
-connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg} srv v =
-  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
+connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
+  getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected
   where
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected smp = do
@@ -372,14 +375,16 @@ smpSubscribeQueues party ca smp srv subs = do
     notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
     notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs
 
-activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
-activeClientSession ca smp srv = sameSess <$> tryReadSessVar srv (smpClients ca)
+activeClientSession' :: SMPClientAgent -> SessionId -> SMPServer -> STM Bool
+activeClientSession' ca sessId srv = sameSess <$> tryReadSessVar srv (smpClients ca)
   where
-    sessId = sessionId . thParams
     sameSess = \case
-      Just (Right (_, smp')) -> sessId smp == sessId smp'
+      Just (Right (_, smp')) -> sessId == sessionId (thParams smp')
       _ -> False
 
+activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
+activeClientSession ca = activeClientSession' ca . sessionId . thParams
+
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)

src/Simplex/Messaging/Crypto.hs

@@ -152,6 +152,12 @@ module Simplex.Messaging.Crypto
     unsafeSbKey,
     randomSbKey,
 
+    -- * secret_box chains
+    SbChainKey,
+    SbKeyNonce,
+    sbcInit,
+    sbcHkdf,
+
     -- * pseudo-random bytes
     randomBytes,
 
@@ -198,6 +204,7 @@ import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
 import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
+import qualified Crypto.KDF.HKDF as H
 import qualified Crypto.MAC.Poly1305 as Poly1305
 import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
@@ -1334,6 +1341,26 @@ unsafeSbKey s = either error id $ sbKey s
 randomSbKey :: TVar ChaChaDRG -> STM SbKey
 randomSbKey gVar = SecretBoxKey <$> randomBytes 32 gVar
 
+newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString}
+  deriving (Eq, Show)
+
+sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey)
+sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2)
+  where
+    prk = H.extract salt secret :: H.PRK SHA512
+    out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64
+    (ck1, ck2) = B.splitAt 32 out
+
+type SbKeyNonce = (SbKey, CbNonce)
+
+sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey)
+sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck')
+  where
+    prk = H.extract B.empty ck :: H.PRK SHA512
+    out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
+    (ck', rest) = B.splitAt 32 out
+    (sk, nonce) = B.splitAt 32 rest
+
 xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
 xSalsa20 secret nonce msg = (rs, msg')
   where

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -17,6 +17,8 @@ module Simplex.Messaging.Crypto.Lazy
     kcbEncryptTailTag,
     sbDecryptTailTag,
     kcbDecryptTailTag,
+    sbEncryptTailTagNoPad,
+    sbDecryptTailTagNoPad,
     fastReplicate,
     secretBox,
     secretBoxTailTag,
@@ -49,7 +51,7 @@ import Data.Composition ((.:.))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Foreign (sizeOf)
-import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
+import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, SbKeyNonce, pattern CbNonce, pattern SbKey)
 import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret (..))
 import Simplex.Messaging.Encoding
 
@@ -142,6 +144,10 @@ sbEncryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString ->
 sbEncryptTailTag_ key (CbNonce nonce) msg len paddedLen =
   LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen)
 
+sbEncryptTailTagNoPad :: SbKeyNonce -> LazyByteString -> Either CryptoError LazyByteString
+sbEncryptTailTagNoPad (SbKey key, CbNonce nonce) msg =
+  LB.fromChunks <$> secretBoxTailTag sbEncryptChunk key nonce msg
+
 -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
 -- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag.
 sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
@@ -165,6 +171,15 @@ sbDecryptTailTag_ key (CbNonce nonce) paddedLen packet =
   where
     (c, tag') = LB.splitAt paddedLen packet
 
+sbDecryptTailTagNoPad :: SbKeyNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
+sbDecryptTailTagNoPad (SbKey key, CbNonce nonce) paddedLen packet =
+  result <$> secretBox sbDecryptChunk key nonce c
+  where
+    result (tag :| cs) =
+      let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag
+       in (valid, LB.fromChunks cs)
+    (c, tag') = LB.splitAt paddedLen packet
+
 secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
 secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where

src/Simplex/Messaging/Crypto/SNTRUP761.hs

@@ -4,7 +4,7 @@
 
 module Simplex.Messaging.Crypto.SNTRUP761 where
 
-import Crypto.Hash (Digest, SHA256, hash)
+import Crypto.Hash (Digest, SHA3_256, hash)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
@@ -28,4 +28,4 @@ kcbEncrypt (KEMHybridSecret k) = sbEncrypt_ k
 kemHybridSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> KEMSharedKey -> KEMHybridSecret
 kemHybridSecret k pk (KEMSharedKey kem) =
   let DhSecretX25519 dh = C.dh' k pk
-   in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA256)
+   in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA3_256)

src/Simplex/Messaging/Encoding.hs

@@ -42,10 +42,12 @@ class Encoding a where
   -- | decoding of type (default implementation uses parser)
   smpDecode :: ByteString -> Either String a
   smpDecode = parseAll smpP
+  {-# INLINE smpDecode #-}
 
   -- | protocol parser of type (default implementation parses protocol ByteString encoding)
   smpP :: Parser a
   smpP = smpDecode <$?> smpP
+  {-# INLINE smpP #-}
 
 instance Encoding Char where
   smpEncode = B.singleton

src/Simplex/Messaging/Encoding/String.hs

@@ -28,6 +28,8 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
 import Data.Int (Int64)
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IS
 import qualified Data.List.NonEmpty as L
 import Data.Set (Set)
 import qualified Data.Set as S
@@ -39,7 +41,7 @@ import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Util ((<$?>))
+import Simplex.Messaging.Util (bshow, (<$?>))
 
 class TextEncoding a where
   textEncode :: a -> Text
@@ -53,14 +55,20 @@ class StrEncoding a where
   -- Please note - if you only specify strDecode, it will use base64urlP as default parser before decoding the string
   strDecode :: ByteString -> Either String a
   strDecode = parseAll strP
+  {-# INLINE strDecode #-}
+
   strP :: Parser a
   strP = strDecode <$?> base64urlP
+  {-# INLINE strP #-}
 
 -- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings
 instance StrEncoding ByteString where
   strEncode = U.encode
+  {-# INLINE strEncode #-}
   strDecode = U.decode
+  {-# INLINE strDecode #-}
   strP = base64urlP
+  {-# INLINE strP #-}
 
 base64urlP :: Parser ByteString
 base64urlP = do
@@ -119,15 +127,15 @@ instance StrEncoding Bool where
   {-# INLINE strP #-}
 
 instance StrEncoding Int where
-  strEncode = B.pack . show
+  strEncode = bshow
   {-# INLINE strEncode #-}
-  strP = A.decimal
+  strP = A.signed A.decimal
   {-# INLINE strP #-}
 
 instance StrEncoding Int64 where
-  strEncode = B.pack . show
+  strEncode = bshow
   {-# INLINE strEncode #-}
-  strP = A.decimal
+  strP = A.signed A.decimal
   {-# INLINE strP #-}
 
 instance StrEncoding SystemTime where
@@ -154,6 +162,10 @@ instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
   strEncode = strEncodeList . S.toList
   strP = S.fromList <$> listItem `A.sepBy'` A.char ','
 
+instance StrEncoding IntSet where
+  strEncode = strEncodeList . IS.toList
+  strP = IS.fromList <$> listItem `A.sepBy'` A.char ','
+
 listItem :: StrEncoding a => Parser a
 listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
 

src/Simplex/Messaging/Notifications/Client.hs

@@ -1,17 +1,20 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Messaging.Notifications.Client where
 
 import Control.Monad.Except
 import Control.Monad.Trans.Except
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import Data.Word (Word16)
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
-import Simplex.Messaging.Protocol (ErrorType)
+import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity)
 
 type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
 
@@ -22,7 +25,7 @@ defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) suppo
 
 ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
 ntfRegisterToken c pKey newTkn =
-  sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
+  sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
     r -> throwE $ unexpectedResponse r
 
@@ -46,10 +49,19 @@ ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
 
 ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
 ntfCreateSubscription c pKey newSub =
-  sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
+  sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
     NRSubId subId -> pure subId
     r -> throwE $ unexpectedResponse r
 
+ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
+ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands "ntfCreateSubscriptions" c cs
+  where
+    cs = L.map (\newSub -> (Just pKey, NoEntity, NtfCmd SSubscription $ SNEW newSub)) newSubs
+    process (Response _ r) = case r of
+      Right (NRSubId subId) -> Right subId
+      Right r' -> Left $ unexpectedResponse r'
+      Left e -> Left e
+
 ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
 ntfCheckSubscription c pKey subId =
   sendNtfCommand c (Just pKey) subId SCHK >>= \case

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -208,7 +208,7 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh
   fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (auth, _, entityId, _) cmd = case cmd of
+  checkCredentials (auth, _, EntityId entityId, _) cmd = case cmd of
     -- TNEW and SNEW must have signature but NOT token/subscription IDs
     TNEW {} -> sigNoEntity
     SNEW {} -> sigNoEntity
@@ -322,7 +322,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (_, _, entId, _) cmd = case cmd of
+  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
     -- IDTKN response must not have queue ID
     NRTknId {} -> noEntity
     -- IDSUB response must not have queue ID
@@ -426,7 +426,7 @@ instance FromJSON DeviceToken where
     t <- encodeUtf8 <$> o .: "token"
     pure $ DeviceToken pp t
 
-type NtfEntityId = ByteString
+type NtfEntityId = EntityId
 
 type NtfSubscriptionId = NtfEntityId
 
@@ -443,6 +443,8 @@ data NtfSubStatus
     NSInactive
   | -- | END received
     NSEnd
+  | -- | DELD received (connection was deleted)
+    NSDeleted
   | -- | SMP AUTH error
     NSAuth
   | -- | SMP error other than AUTH
@@ -456,6 +458,7 @@ ntfShouldSubscribe = \case
   NSActive -> True
   NSInactive -> True
   NSEnd -> False
+  NSDeleted -> False
   NSAuth -> False
   NSErr _ -> False
 
@@ -466,6 +469,7 @@ instance Encoding NtfSubStatus where
     NSActive -> "ACTIVE"
     NSInactive -> "INACTIVE"
     NSEnd -> "END"
+    NSDeleted -> "DELETED"
     NSAuth -> "AUTH"
     NSErr err -> "ERR " <> err
   smpP =
@@ -475,6 +479,7 @@ instance Encoding NtfSubStatus where
       "ACTIVE" -> pure NSActive
       "INACTIVE" -> pure NSInactive
       "END" -> pure NSEnd
+      "DELETED" -> pure NSDeleted
       "AUTH" -> pure NSAuth
       "ERR" -> NSErr <$> (A.space *> A.takeByteString)
       _ -> fail "bad NtfSubStatus"

src/Simplex/Messaging/Notifications/Server.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -19,6 +20,7 @@ import Control.Monad.Reader
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import Data.IORef
 import Data.Int (Int64)
 import Data.List (intercalate, sort)
 import Data.List.NonEmpty (NonEmpty (..))
@@ -30,6 +32,7 @@ import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
+import GHC.IORef (atomicSwapIORef)
 import Network.Socket (ServiceName)
 import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..))
 import Simplex.Messaging.Client.Agent
@@ -42,7 +45,7 @@ import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
 import Simplex.Messaging.Notifications.Transport
-import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Stats
@@ -118,16 +121,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
           hSetBuffering h LineBuffering
           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
+          fromTime' <- atomicSwapIORef fromTime ts
+          tknCreated' <- atomicSwapIORef tknCreated 0
+          tknVerified' <- atomicSwapIORef tknVerified 0
+          tknDeleted' <- atomicSwapIORef tknDeleted 0
+          subCreated' <- atomicSwapIORef subCreated 0
+          subDeleted' <- atomicSwapIORef subDeleted 0
+          ntfReceived' <- atomicSwapIORef ntfReceived 0
+          ntfDelivered' <- atomicSwapIORef ntfDelivered 0
+          tkn <- liftIO $ periodStatCounts activeTokens ts
+          sub <- liftIO $ periodStatCounts activeSubs ts
           hPutStrLn h $
             intercalate
               ","
@@ -203,7 +206,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
     receiveSMP :: M ()
     receiveSMP = forever $ do
-      ((_, srv, _), _, _, ts) <- atomically $ readTBQueue msgQ
+      ((_, srv, _), _thVersion, sessionId, ts) <- atomically $ readTBQueue msgQ
       forM ts $ \(ntfId, t) -> case t of
         STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen
         STResponse {} -> pure () -- it was already reported as timeout error
@@ -215,12 +218,15 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
               st <- asks store
               NtfPushServer {pushQ} <- asks pushServer
               stats <- asks serverStats
-              atomically $ updatePeriodStats (activeSubs stats) ntfId
+              liftIO $ updatePeriodStats (activeSubs stats) ntfId
               atomically $
                 findNtfSubscriptionToken st smpQueue
-                  >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
+                  >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| [])))
               incNtfStat ntfReceived
-            Right SMP.END -> updateSubStatus smpQueue NSEnd
+            Right SMP.END ->
+              whenM (atomically $ activeClientSession' ca sessionId srv) $
+                updateSubStatus smpQueue NSEnd
+            Right SMP.DELD -> updateSubStatus smpQueue NSDeleted
             Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e
             Right _ -> logError "SMP server unexpected response"
             Left e -> logError $ "SMP client error: " <> tshow e
@@ -297,7 +303,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
       void $ deliverNotification pp tkn ntf
     PNMessage {} -> checkActiveTkn status $ do
       stats <- asks serverStats
-      atomically $ updatePeriodStats (activeTokens stats) ntfTknId
+      liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
       void $ deliverNotification pp tkn ntf
       incNtfStat ntfDelivered
   where
@@ -444,7 +450,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
         withNtfLog (`logCreateToken` tkn)
         incNtfStatT token tknCreated
-        pure (corrId, "", NRTknId tknId srvDhPubKey)
+        pure (corrId, NoEntity, NRTknId tknId srvDhPubKey)
       NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
         (corrId,tknId,) <$> case cmd of
@@ -535,7 +541,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             _ -> pure $ NRErr AUTH
         withNtfLog (`logCreateSubscription` sub)
         incNtfStat subCreated
-        pure (corrId, "", resp)
+        pure (corrId, NoEntity, resp)
       NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         status <- readTVarIO subStatus
         (corrId,subId,) <$> case cmd of
@@ -560,7 +566,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
           PING -> pure NRPong
       NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
     getId :: M NtfEntityId
-    getId = randomBytes =<< asks (subIdBytes . config)
+    getId = fmap EntityId . randomBytes =<< asks (subIdBytes . config)
     getRegCode :: M NtfRegCode
     getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config))
     randomBytes :: Int -> M ByteString
@@ -573,14 +579,14 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
 withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withNtfLog action = liftIO . mapM_ action =<< asks storeLog
 
-incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M ()
+incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M ()
 incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
 incNtfStatT _ statSel = incNtfStat statSel
 
-incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
+incNtfStat :: (NtfServerStats -> IORef Int) -> M ()
 incNtfStat statSel = do
   stats <- asks serverStats
-  atomically $ modifyTVar' (statSel stats) (+ 1)
+  liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
 
 saveServerStats :: M ()
 saveServerStats =
@@ -600,7 +606,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          atomically $ setNtfServerStats s d
+          liftIO $ setNtfServerStats s d
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
         Left e -> do

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -15,7 +16,7 @@ import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
-import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
+import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Server (runNtfServer)
@@ -84,13 +85,19 @@ ntfServerCLI cfgPath logPath =
             <> ("enable: " <> onOff enableStoreLog <> "\n\n")
             <> "log_stats: off\n\n\
                \[TRANSPORT]\n\
-               \# host is only used to print server address on start\n"
+               \# Host is only used to print server address on start.\n\
+               \# You can specify multiple server ports.\n"
             <> ("host: " <> T.pack host <> "\n")
             <> ("port: " <> T.pack defaultServerPort <> "\n")
-            <> "log_tls_errors: off\n"
-            <> "websockets: off\n\n\
+            <> "log_tls_errors: off\n\n\
+               \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
+               \websockets: off\n\n\
                \[SUBSCRIBER]\n\
                \# Network configuration for notification server client.\n\
+               \# `host_mode` can be 'public' (default) or 'onion'.\n\
+               \# It defines prefferred hostname for destination servers with multiple hostnames.\n\
+               \# host_mode: public\n\
+               \# required_host_mode: off\n\n\
                \# SOCKS proxy port for subscribing to SMP servers.\n\
                \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
                \# socks_proxy: localhost:9050\n\n\
@@ -132,7 +139,10 @@ ntfServerCLI cfgPath logPath =
                         { networkConfig =
                             defaultNetworkConfig
                               { socksProxy = either error id <$!> strDecodeIni "SUBSCRIBER" "socks_proxy" ini,
-                                socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini
+                                socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
+                                hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
+                                requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
+                                smpPingInterval = 60_000_000 -- 1 minutes
                               }
                         },
                     persistErrorInterval = 0 -- seconds

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

@@ -28,12 +28,16 @@ import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
@@ -103,11 +107,20 @@ readECPrivateKey f = do
 
 data PushNotification
   = PNVerification NtfRegCode
-  | PNMessage PNMessageData
+  | PNMessage (NonEmpty PNMessageData)
   | -- | PNAlert Text
     PNCheckMessages
   deriving (Show)
 
+-- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
+-- because strEncode of NonEmpty list uses comma for separator,
+-- and encoding of PNMessageData's smpQueue has comma in list of hosts
+encodePNMessages :: NonEmpty PNMessageData -> ByteString
+encodePNMessages = B.intercalate ";" . map strEncode . L.toList
+
+pnMessagesP :: A.Parser (NonEmpty PNMessageData)
+pnMessagesP = L.fromList <$> strP `A.sepBy1` A.char ';'
+
 data PNMessageData = PNMessageData
   { smpQueue :: SMPQueueNtf,
     ntfTs :: SystemTime,
@@ -285,7 +298,7 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
     encrypt code $ \code' ->
       apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
   PNMessage pnMessageData ->
-    encrypt (strEncode pnMessageData) $ \ntfData ->
+    encrypt (encodePNMessages pnMessageData) $ \ntfData ->
       apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
   -- PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
   PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]

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

@@ -7,24 +7,22 @@ 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.IORef
 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
+  { fromTime :: IORef UTCTime,
+    tknCreated :: IORef Int,
+    tknVerified :: IORef Int,
+    tknDeleted :: IORef Int,
+    subCreated :: IORef Int,
+    subDeleted :: IORef Int,
+    ntfReceived :: IORef Int,
+    ntfDelivered :: IORef Int,
+    activeTokens :: PeriodStats,
+    activeSubs :: PeriodStats
   }
 
 data NtfServerStatsData = NtfServerStatsData
@@ -36,48 +34,49 @@ data NtfServerStatsData = NtfServerStatsData
     _subDeleted :: Int,
     _ntfReceived :: Int,
     _ntfDelivered :: Int,
-    _activeTokens :: PeriodStatsData NtfTokenId,
-    _activeSubs :: PeriodStatsData NotifierId
+    _activeTokens :: PeriodStatsData,
+    _activeSubs :: PeriodStatsData
   }
 
 newNtfServerStats :: UTCTime -> IO NtfServerStats
 newNtfServerStats ts = do
-  fromTime <- newTVarIO ts
-  tknCreated <- newTVarIO 0
-  tknVerified <- newTVarIO 0
-  tknDeleted <- newTVarIO 0
-  subCreated <- newTVarIO 0
-  subDeleted <- newTVarIO 0
-  ntfReceived <- newTVarIO 0
-  ntfDelivered <- newTVarIO 0
+  fromTime <- newIORef ts
+  tknCreated <- newIORef 0
+  tknVerified <- newIORef 0
+  tknDeleted <- newIORef 0
+  subCreated <- newIORef 0
+  subDeleted <- newIORef 0
+  ntfReceived <- newIORef 0
+  ntfDelivered <- newIORef 0
   activeTokens <- newPeriodStats
   activeSubs <- newPeriodStats
   pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
 
 getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData
 getNtfServerStatsData s@NtfServerStats {fromTime} = do
-  _fromTime <- readTVarIO fromTime
-  _tknCreated <- readTVarIO $ tknCreated s
-  _tknVerified <- readTVarIO $ tknVerified s
-  _tknDeleted <- readTVarIO $ tknDeleted s
-  _subCreated <- readTVarIO $ subCreated s
-  _subDeleted <- readTVarIO $ subDeleted s
-  _ntfReceived <- readTVarIO $ ntfReceived s
-  _ntfDelivered <- readTVarIO $ ntfDelivered s
+  _fromTime <- readIORef fromTime
+  _tknCreated <- readIORef $ tknCreated s
+  _tknVerified <- readIORef $ tknVerified s
+  _tknDeleted <- readIORef $ tknDeleted s
+  _subCreated <- readIORef $ subCreated s
+  _subDeleted <- readIORef $ subDeleted s
+  _ntfReceived <- readIORef $ ntfReceived s
+  _ntfDelivered <- readIORef $ 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 ()
+-- this function is not thread safe, it is used on server start only
+setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO ()
 setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} = do
-  writeTVar fromTime $! _fromTime
-  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
+  writeIORef fromTime $! _fromTime
+  writeIORef (tknCreated s) $! _tknCreated d
+  writeIORef (tknVerified s) $! _tknVerified d
+  writeIORef (tknDeleted s) $! _tknDeleted d
+  writeIORef (subCreated s) $! _subCreated d
+  writeIORef (subDeleted s) $! _subDeleted d
+  writeIORef (ntfReceived s) $! _ntfReceived d
+  writeIORef (ntfDelivered s) $! _ntfDelivered d
   setPeriodStats (activeTokens s) (_activeTokens d)
   setPeriodStats (activeSubs s) (_activeSubs d)
 

src/Simplex/Messaging/Notifications/Types.hs

@@ -99,8 +99,8 @@ type NtfActionTs = UTCTime
 data NtfSubNTFAction
   = NSACreate
   | NSACheck
-  | NSADelete
-  | NSARotate
+  | NSADelete -- deprecated
+  | NSARotate -- deprecated
   deriving (Show)
 
 instance Encoding NtfSubNTFAction where

src/Simplex/Messaging/Protocol.hs

@@ -2,11 +2,13 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -99,7 +101,8 @@ module Simplex.Messaging.Protocol
     BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
-    EntityId,
+    EntityId (..),
+    pattern NoEntity,
     QueueId,
     RecipientId,
     SenderId,
@@ -329,8 +332,8 @@ data RawTransmission = RawTransmission
   { authenticator :: ByteString, -- signature or encrypted transmission hash
     authorized :: ByteString, -- authorized transmission
     sessId :: SessionId,
-    corrId :: ByteString,
-    entityId :: ByteString,
+    corrId :: CorrId,
+    entityId :: EntityId,
     command :: ByteString
   }
   deriving (Show)
@@ -357,7 +360,7 @@ instance IsString (Maybe TransmissionAuth) where
   fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature
 
 -- | unparsed sent SMP transmission with signature, without session ID.
-type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString)
+type SignedRawTransmission = (Maybe TransmissionAuth, CorrId, EntityId, ByteString)
 
 -- | unparsed sent SMP transmission with signature.
 type SentRawTransmission = (Maybe TransmissionAuth, ByteString)
@@ -374,7 +377,13 @@ type NotifierId = QueueId
 -- | SMP queue ID on the server.
 type QueueId = EntityId
 
-type EntityId = ByteString
+-- this type is used for server entities only
+newtype EntityId = EntityId {unEntityId :: ByteString}
+  deriving (Eq, Ord, Show)
+  deriving newtype (Encoding, StrEncoding)
+
+pattern NoEntity :: EntityId
+pattern NoEntity = EntityId ""
 
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
@@ -475,6 +484,7 @@ data BrokerMsg where
   RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
   PRES :: EncResponse -> BrokerMsg -- proxy to client
   END :: BrokerMsg
+  DELD :: BrokerMsg
   INFO :: QueueInfo -> BrokerMsg
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
@@ -696,6 +706,7 @@ data BrokerMsgTag
   | RRES_
   | PRES_
   | END_
+  | DELD_
   | INFO_
   | OK_
   | ERR_
@@ -769,6 +780,7 @@ instance Encoding BrokerMsgTag where
     RRES_ -> "RRES"
     PRES_ -> "PRES"
     END_ -> "END"
+    DELD_ -> "DELD"
     INFO_ -> "INFO"
     OK_ -> "OK"
     ERR_ -> "ERR"
@@ -785,6 +797,7 @@ instance ProtocolMsgTag BrokerMsgTag where
     "RRES" -> Just RRES_
     "PRES" -> Just PRES_
     "END" -> Just END_
+    "DELD" -> Just DELD_
     "INFO" -> Just INFO_
     "OK" -> Just OK_
     "ERR" -> Just ERR_
@@ -1097,10 +1110,13 @@ serverStrP = do
     portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
 -- | Transmission correlation ID.
-newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
+newtype CorrId = CorrId {bs :: ByteString}
+  deriving (Eq, Ord, Show)
+  deriving newtype (Encoding)
 
 instance IsString CorrId where
   fromString = CorrId . fromString
+  {-# INLINE fromString #-}
 
 instance StrEncoding CorrId where
   strEncode (CorrId cId) = strEncode cId
@@ -1262,7 +1278,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
       command <- A.takeByteString
       pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
 
-class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
+class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
   protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
@@ -1323,7 +1339,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (auth, _, entId, _) cmd = case cmd of
+  checkCredentials (auth, _, EntityId entId, _) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
     NEW {}
       | isNothing auth -> Left $ CMD NO_AUTH
@@ -1411,6 +1427,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
     PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
     END -> e END_
+    DELD
+      | v >= deletedEventSMPVersion -> e DELD_
+      | otherwise -> e END_
     INFO info -> e (INFO_, ' ', info)
     OK -> e OK_
     ERR err -> e (ERR_, ' ', err)
@@ -1436,6 +1455,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
     PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
     END_ -> pure END
+    DELD_ -> pure DELD
     INFO_ -> INFO <$> _smpP
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP
@@ -1448,7 +1468,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (_, _, entId, _) cmd = case cmd of
+  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
     -- IDS response should not have queue ID
     IDS _ -> Right cmd
     -- ERR response does not always have queue ID
@@ -1721,16 +1741,16 @@ tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \ca
     | implySessId || sessId == sessionId ->
         let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator
          in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission
-    | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PESession))
+    | otherwise -> (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PESession))
   Left _ -> tError ""
   where
-    tError :: ByteString -> SignedTransmission err cmd
-    tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PEBlock))
+    tError :: CorrId -> SignedTransmission err cmd
+    tError corrId = (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PEBlock))
 
     tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd
     tParseValidate signed t@(sig, corrId, entityId, command) =
       let cmd = parseProtocol @v @err @cmd v command >>= checkCredentials t
-       in (sig, signed, (CorrId corrId, entityId, cmd))
+       in (sig, signed, (corrId, entityId, cmd))
 
 $(J.deriveJSON defaultJSON ''MsgFlags)
 

src/Simplex/Messaging/Server/CLI.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Server.CLI where
@@ -16,6 +17,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue)
+import Data.List ((\\))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
@@ -275,9 +277,15 @@ checkSavedFingerprint cfgPath x509cfg = do
 
 iniTransports :: Ini -> [(String, ATransport)]
 iniTransports ini =
-  let port = T.unpack $ strictIni "TRANSPORT" "port" ini
-      enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
-   in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
+  let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
+      ws = strictIni "TRANSPORT" "websockets" ini
+      wsPorts
+        | ws == "off" = []
+        | ws == "on" = ["80"]
+        | otherwise = ports ws \\ smpPorts
+   in map (,transport @TLS) smpPorts <> map (,transport @WS) wsPorts
+  where
+    ports = map T.unpack . T.splitOn ","
 
 printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
 printServerConfig transports logFile = do

src/Simplex/Messaging/Server/Control.hs

@@ -4,9 +4,8 @@
 module Simplex.Messaging.Server.Control where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString (ByteString)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BasicAuth)
+import Simplex.Messaging.Protocol (BasicAuth, SenderId)
 
 data CPClientRole = CPRNone | CPRUser | CPRAdmin
   deriving (Eq)
@@ -22,7 +21,7 @@ data ControlProtocol
   | CPSockets
   | CPSocketThreads
   | CPServerInfo
-  | CPDelete ByteString
+  | CPDelete SenderId
   | CPSave
   | CPHelp
   | CPQuit

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

@@ -76,6 +76,8 @@ data ServerConfig = ServerConfig
     serverStatsLogFile :: FilePath,
     -- | file to save and restore stats
     serverStatsBackupFile :: Maybe FilePath,
+    -- | interval between sending pending END events to unsubscribed clients, seconds
+    pendingENDInterval :: Int,
     -- | CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
@@ -127,17 +129,23 @@ data Env = Env
     serverStats :: ServerStats,
     sockets :: SocketState,
     clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap Client),
+    clients :: TVar (IntMap (Maybe Client)),
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
 type Subscribed = Bool
 
 data Server = Server
-  { subscribedQ :: TQueue (RecipientId, Client, Subscribed),
-    subscribers :: TMap RecipientId Client,
-    ntfSubscribedQ :: TQueue (NotifierId, Client, Subscribed),
-    notifiers :: TMap NotifierId Client,
+  { subscribedQ :: TQueue (RecipientId, ClientId),
+    deletedQ :: TQueue (RecipientId, ClientId),
+    subscribers :: TMap RecipientId (TVar Client),
+    ntfSubscribedQ :: TQueue (NotifierId, ClientId),
+    ntfDeletedQ :: TQueue (NotifierId, ClientId),
+    notifiers :: TMap NotifierId (TVar Client),
+    pendingENDs :: TVar (IntMap (NonEmpty RecipientId)),
+    pendingDELDs :: TVar (IntMap (NonEmpty RecipientId)),
+    pendingNtfENDs :: TVar (IntMap (NonEmpty NotifierId)),
+    pendingNtfDELDs :: TVar (IntMap (NonEmpty NotifierId)),
     savingLock :: Lock
   }
 
@@ -177,15 +185,20 @@ data Sub = Sub
 newServer :: IO Server
 newServer = do
   subscribedQ <- newTQueueIO
+  deletedQ <- newTQueueIO
   subscribers <- TM.emptyIO
   ntfSubscribedQ <- newTQueueIO
+  ntfDeletedQ <- newTQueueIO
   notifiers <- TM.emptyIO
+  pendingENDs <- newTVarIO IM.empty
+  pendingDELDs <- newTVarIO IM.empty
+  pendingNtfENDs <- newTVarIO IM.empty
+  pendingNtfDELDs <- newTVarIO IM.empty
   savingLock <- atomically createLock
-  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
+  return Server {subscribedQ, deletedQ, subscribers, ntfSubscribedQ, ntfDeletedQ, notifiers, pendingENDs, pendingDELDs, pendingNtfENDs, pendingNtfDELDs, savingLock}
 
-newClient :: TVar ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
-newClient nextClientId qSize thVersion sessionId createdAt = do
-  clientId <- atomically $ stateTVar nextClientId $ \next -> (next, next + 1)
+newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
+newClient clientId qSize thVersion sessionId createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
   rcvQ <- newTBQueueIO qSize

src/Simplex/Messaging/Server/Main.hs

@@ -29,7 +29,7 @@ import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
 import Simplex.Messaging.Agent.Protocol (connReqUriP')
-import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
+import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -168,10 +168,12 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                    \# control_port_admin_password:\n\
                    \# control_port_user_password:\n\n\
                    \[TRANSPORT]\n\
-                   \# host is only used to print server address on start\n"
+                   \# Host is only used to print server address on start.\n\
+                   \# You can specify multiple server ports.\n"
                 <> ("host: " <> T.pack host <> "\n")
                 <> ("port: " <> T.pack defaultServerPort <> "\n")
-                <> "log_tls_errors: off\n\
+                <> "log_tls_errors: off\n\n\
+                   \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
                    \websockets: off\n\
                    \# control_port: 5224\n\n\
                    \[PROXY]\n\
@@ -254,7 +256,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
           ServerConfig
             { transports = iniTransports ini,
               smpHandshakeTimeout = 120000000,
-              tbqSize = 64,
+              tbqSize = 128,
               msgQueueQuota = 128,
               queueIdBytes = 24,
               msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
@@ -289,6 +291,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
+              pendingENDInterval = 15000000, -- 15 seconds
               smpServerVRange = supportedServerSMPRelayVRange,
               transportConfig =
                 defaultTransportServerConfig
@@ -306,7 +309,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                             defaultNetworkConfig
                               { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
                                 socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
-                                hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini,
+                                hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini,
                                 requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
                               }
                         },
@@ -317,11 +320,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
               serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
               information = serverPublicInfo ini
             }
-        textToHostMode :: Text -> HostMode
-        textToHostMode = \case
-          "public" -> HMPublic
-          "onion" -> HMOnionViaSocks
-          s -> error . T.unpack $ "Invalid host_mode: " <> s
         textToOwnServers :: Text -> [ByteString]
         textToOwnServers = map encodeUtf8 . T.words
 

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

@@ -9,17 +9,18 @@
 
 module Simplex.Messaging.Server.MsgStore.STM
   ( STMMsgStore,
-    MsgQueue (..),
+    MsgQueue (msgQueue),
     newMsgStore,
     getMsgQueue,
     delMsgQueue,
     delMsgQueueSize,
     writeMsg,
     tryPeekMsg,
-    peekMsg,
+    tryPeekMsgIO,
     tryDelMsg,
     tryDelPeekMsg,
     deleteExpiredMsgs,
+    getQueueSize,
   )
 where
 
@@ -44,9 +45,14 @@ type STMMsgStore = TMap RecipientId MsgQueue
 newMsgStore :: IO STMMsgStore
 newMsgStore = TM.emptyIO
 
-getMsgQueue :: STMMsgStore -> RecipientId -> Int -> STM MsgQueue
-getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
+-- The reason for double lookup is that majority of messaging queues exist,
+-- because multiple messages are sent to the same queue,
+-- so the first lookup without STM transaction will return the queue faster.
+-- In case the queue does not exist, it needs to be looked-up again inside transaction.
+getMsgQueue :: STMMsgStore -> RecipientId -> Int -> IO MsgQueue
+getMsgQueue st rId quota = TM.lookupIO rId st >>= maybe (atomically maybeNewQ) pure
   where
+    maybeNewQ = TM.lookup rId st >>= maybe newQ pure
     newQ = do
       msgQueue <- newTQueue
       canWrite <- newTVar True
@@ -55,14 +61,14 @@ getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
       TM.insert rId q st
       pure q
 
-delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
-delMsgQueue st rId = TM.delete rId st
+delMsgQueue :: STMMsgStore -> RecipientId -> IO ()
+delMsgQueue st rId = atomically $ TM.delete rId st
 
-delMsgQueueSize :: STMMsgStore -> RecipientId -> STM Int
-delMsgQueueSize st rId = TM.lookupDelete rId st >>= maybe (pure 0) (\MsgQueue {size} -> readTVar size)
+delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int
+delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size)
 
-writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool))
-writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do
+writeMsg :: MsgQueue -> Message -> IO (Maybe (Message, Bool))
+writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do
   canWrt <- readTVar canWrite
   empty <- isEmptyTQueue q
   if canWrt || empty
@@ -77,43 +83,47 @@ writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do
   where
     msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
 
+tryPeekMsgIO :: MsgQueue -> IO (Maybe Message)
+tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue
+{-# INLINE tryPeekMsgIO #-}
+
+-- TODO remove once deliverToSub is split
 tryPeekMsg :: MsgQueue -> STM (Maybe Message)
 tryPeekMsg = tryPeekTQueue . msgQueue
 {-# INLINE tryPeekMsg #-}
 
-peekMsg :: MsgQueue -> STM Message
-peekMsg = peekTQueue . msgQueue
-{-# INLINE peekMsg #-}
-
-tryDelMsg :: MsgQueue -> MsgId -> STM (Maybe Message)
-tryDelMsg mq msgId' =
+tryDelMsg :: MsgQueue -> MsgId -> IO (Maybe Message)
+tryDelMsg mq msgId' = atomically $
   tryPeekMsg mq >>= \case
     msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_
+      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg_ mq >> pure msg_
       | otherwise -> pure Nothing
     _ -> pure Nothing
 
 -- atomic delete (== read) last and peek next message if available
-tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message)
-tryDelPeekMsg mq msgId' =
+tryDelPeekMsg :: MsgQueue -> MsgId -> IO (Maybe Message, Maybe Message)
+tryDelPeekMsg mq msgId' = atomically $
   tryPeekMsg mq >>= \case
     msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
+      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg mq)
       | otherwise -> pure (Nothing, msg_)
     _ -> pure (Nothing, Nothing)
 
-deleteExpiredMsgs :: MsgQueue -> Int64 -> STM Int
-deleteExpiredMsgs mq old = loop 0
+deleteExpiredMsgs :: MsgQueue -> Int64 -> IO Int
+deleteExpiredMsgs mq old = atomically $ loop 0
   where
     loop dc =
       tryPeekMsg mq >>= \case
         Just Message {msgTs}
           | systemSeconds msgTs < old ->
-              tryDeleteMsg mq >> loop (dc + 1)
+              tryDeleteMsg_ mq >> loop (dc + 1)
         _ -> pure dc
 
-tryDeleteMsg :: MsgQueue -> STM ()
-tryDeleteMsg MsgQueue {msgQueue = q, size} =
+tryDeleteMsg_ :: MsgQueue -> STM ()
+tryDeleteMsg_ MsgQueue {msgQueue = q, size} =
   tryReadTQueue q >>= \case
     Just _ -> modifyTVar' size (subtract 1)
     _ -> pure ()
+
+getQueueSize :: MsgQueue -> IO Int
+getQueueSize MsgQueue {size} = readTVarIO size

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.QueueStore where
 
+import Data.Int (Int64)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 
@@ -16,7 +19,8 @@ data QueueRec = QueueRec
     senderKey :: !(Maybe SndPublicAuthKey),
     sndSecure :: !SenderCanSecure,
     notifier :: !(Maybe NtfCreds),
-    status :: !ServerQueueStatus
+    status :: !ServerQueueStatus,
+    updatedAt :: !(Maybe RoundedSystemTime)
   }
   deriving (Show)
 
@@ -34,3 +38,16 @@ instance StrEncoding NtfCreds where
     pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
 
 data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)
+
+newtype RoundedSystemTime = RoundedSystemTime Int64
+  deriving (Eq, Ord, Show)
+
+instance StrEncoding RoundedSystemTime where
+  strEncode (RoundedSystemTime t) = strEncode t
+  strP = RoundedSystemTime <$> strP
+
+getRoundedSystemTime :: Int64 -> IO RoundedSystemTime
+getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime
+
+getSystemDate :: IO RoundedSystemTime
+getSystemDate = getRoundedSystemTime 86400

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

@@ -19,6 +19,7 @@ module Simplex.Messaging.Server.QueueStore.STM
     addQueueNotifier,
     deleteQueueNotifier,
     suspendQueue,
+    updateQueueTime,
     deleteQueue,
   )
 where
@@ -45,8 +46,8 @@ newQueueStore = do
   notifiers <- TM.emptyIO
   pure QueueStore {queues, senders, notifiers}
 
-addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
-addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
+addQueue :: QueueStore -> QueueRec -> IO (Either ErrorType ())
+addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = atomically $ do
   ifM hasId (pure $ Left DUPLICATE_) $ do
     qVar <- newTVar q
     TM.insert rId qVar queues
@@ -55,48 +56,55 @@ addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId =
   where
     hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
 
-getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
+getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> IO (Either ErrorType QueueRec)
 getQueue QueueStore {queues, senders, notifiers} party qId =
-  toResult <$> (mapM readTVar =<< getVar)
+  toResult <$> (mapM readTVarIO =<< getVar)
   where
     getVar = case party of
-      SRecipient -> TM.lookup qId queues
-      SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
-      SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
+      SRecipient -> TM.lookupIO qId queues
+      SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
+      SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
 
-secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> STM (Either ErrorType QueueRec)
-secureQueue QueueStore {queues} rId sKey =
-  withQueue rId queues $ \qVar ->
+secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> IO (Either ErrorType QueueRec)
+secureQueue QueueStore {queues} rId sKey = toResult <$> do
+  TM.lookupIO rId queues $>>= \qVar -> atomically $ 
     readTVar qVar >>= \q -> case senderKey q of
       Just k -> pure $ if sKey == k then Just q else Nothing
       _ ->
         let !q' = q {senderKey = Just sKey}
          in writeTVar qVar q' $> Just q'
 
-addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
+addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
 addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
-  ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
-    withQueue rId queues $ \qVar -> do
+  TM.lookupIO rId queues >>= \case
+    Just qVar -> atomically $ ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
       q <- readTVar qVar
-      forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
-      writeTVar qVar $! q {notifier = Just ntfCreds}
+      nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
+      let !q' = q {notifier = Just ntfCreds}
+      writeTVar qVar q'
       TM.insert nId rId notifiers
-      pure $ Just q
+      pure $ Right nId_
+    Nothing -> pure $ Left AUTH
 
-deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+deleteQueueNotifier :: QueueStore -> RecipientId -> IO (Either ErrorType (Maybe NotifierId))
 deleteQueueNotifier QueueStore {queues, notifiers} rId =
   withQueue rId queues $ \qVar -> do
     q <- readTVar qVar
-    forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-    writeTVar qVar $! q {notifier = Nothing}
-    pure $ Just ()
+    forM (notifier q) $ \NtfCreds {notifierId} -> do
+      TM.delete notifierId notifiers
+      writeTVar qVar $! q {notifier = Nothing}
+      pure notifierId
 
-suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+suspendQueue :: QueueStore -> RecipientId -> IO (Either ErrorType ())
 suspendQueue QueueStore {queues} rId =
-  withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
+  withQueue rId queues (`modifyTVar'` \q -> q {status = QueueOff})
 
-deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType QueueRec)
-deleteQueue QueueStore {queues, senders, notifiers} rId = do
+updateQueueTime :: QueueStore -> RecipientId -> RoundedSystemTime -> IO ()
+updateQueueTime QueueStore {queues} rId t =
+  void $ withQueue rId queues (`modifyTVar'` \q -> q {updatedAt = Just t})
+
+deleteQueue :: QueueStore -> RecipientId -> IO (Either ErrorType QueueRec)
+deleteQueue QueueStore {queues, senders, notifiers} rId = atomically $ do
   TM.lookupDelete rId queues >>= \case
     Just qVar ->
       readTVar qVar >>= \q -> do
@@ -108,5 +116,5 @@ deleteQueue QueueStore {queues, senders, notifiers} rId = do
 toResult :: Maybe a -> Either ErrorType a
 toResult = maybe (Left AUTH) Right
 
-withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a)
-withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f
+withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM a) -> IO (Either ErrorType a)
+withQueue rId queues f = toResult <$> TM.lookupIO rId queues >>= atomically . mapM f

src/Simplex/Messaging/Server/Stats.hs

@@ -4,65 +4,78 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Server.Stats where
 
 import Control.Applicative (optional, (<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Hashable (hash)
+import Data.IORef
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IS
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Time.Calendar.Month (pattern MonthDay)
 import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..))
+import GHC.IORef (atomicSwapIORef)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RecipientId)
-import UnliftIO.STM
+import Simplex.Messaging.Protocol (EntityId (..))
+import Simplex.Messaging.Util (atomicModifyIORef'_, unlessM)
 
 data ServerStats = ServerStats
-  { fromTime :: TVar UTCTime,
-    qCreated :: TVar Int,
-    qSecured :: TVar Int,
-    qDeletedAll :: TVar Int,
-    qDeletedNew :: TVar Int,
-    qDeletedSecured :: TVar Int,
-    qSub :: TVar Int,
-    qSubNoMsg :: TVar Int,
-    qSubAuth :: TVar Int,
-    qSubDuplicate :: TVar Int,
-    qSubProhibited :: TVar Int,
-    ntfCreated :: TVar Int,
-    ntfDeleted :: TVar Int,
-    ntfSub :: TVar Int,
-    ntfSubAuth :: TVar Int,
-    ntfSubDuplicate :: TVar Int,
-    msgSent :: TVar Int,
-    msgSentAuth :: TVar Int,
-    msgSentQuota :: TVar Int,
-    msgSentLarge :: TVar Int,
-    msgRecv :: TVar Int,
-    msgRecvGet :: TVar Int,
-    msgGet :: TVar Int,
-    msgGetNoMsg :: TVar Int,
-    msgGetAuth :: TVar Int,
-    msgGetDuplicate :: TVar Int,
-    msgGetProhibited :: TVar Int,
-    msgExpired :: TVar Int,
-    activeQueues :: PeriodStats RecipientId,
-    subscribedQueues :: PeriodStats RecipientId,
-    msgSentNtf :: TVar Int, -- sent messages with NTF flag
-    msgRecvNtf :: TVar Int, -- received messages with NTF flag
-    activeQueuesNtf :: PeriodStats RecipientId,
-    msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf)
-    msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected)
-    msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full
+  { fromTime :: IORef UTCTime,
+    qCreated :: IORef Int,
+    qSecured :: IORef Int,
+    qDeletedAll :: IORef Int,
+    qDeletedAllB :: IORef Int,
+    qDeletedNew :: IORef Int,
+    qDeletedSecured :: IORef Int,
+    qSub :: IORef Int, -- only includes subscriptions when there were pending messages
+    -- qSubNoMsg :: IORef Int, -- this stat creates too many STM transactions
+    qSubAllB :: IORef Int, -- count of all subscription batches (with and without pending messages)
+    qSubAuth :: IORef Int,
+    qSubDuplicate :: IORef Int,
+    qSubProhibited :: IORef Int,
+    qSubEnd :: IORef Int,
+    qSubEndB :: IORef Int,
+    ntfCreated :: IORef Int,
+    ntfDeleted :: IORef Int,
+    ntfDeletedB :: IORef Int,
+    ntfSub :: IORef Int,
+    ntfSubB :: IORef Int,
+    ntfSubAuth :: IORef Int,
+    ntfSubDuplicate :: IORef Int,
+    msgSent :: IORef Int,
+    msgSentAuth :: IORef Int,
+    msgSentQuota :: IORef Int,
+    msgSentLarge :: IORef Int,
+    msgRecv :: IORef Int,
+    msgRecvGet :: IORef Int,
+    msgGet :: IORef Int,
+    msgGetNoMsg :: IORef Int,
+    msgGetAuth :: IORef Int,
+    msgGetDuplicate :: IORef Int,
+    msgGetProhibited :: IORef Int,
+    msgExpired :: IORef Int,
+    activeQueues :: PeriodStats,
+    -- subscribedQueues :: PeriodStats, -- this stat uses too much memory
+    msgSentNtf :: IORef Int, -- sent messages with NTF flag
+    msgRecvNtf :: IORef Int, -- received messages with NTF flag
+    activeQueuesNtf :: PeriodStats,
+    msgNtfs :: IORef Int, -- messages notications delivered to NTF server (<= msgSentNtf)
+    msgNtfNoSub :: IORef Int, -- no subscriber to notifications (e.g., NTF server not connected)
+    msgNtfLost :: IORef Int, -- notification is lost because NTF delivery queue is full
     pRelays :: ProxyStats,
     pRelaysOwn :: ProxyStats,
     pMsgFwds :: ProxyStats,
     pMsgFwdsOwn :: ProxyStats,
-    pMsgFwdsRecv :: TVar Int,
-    qCount :: TVar Int,
-    msgCount :: TVar Int
+    pMsgFwdsRecv :: IORef Int,
+    qCount :: IORef Int,
+    msgCount :: IORef Int
   }
 
 data ServerStatsData = ServerStatsData
@@ -70,16 +83,21 @@ data ServerStatsData = ServerStatsData
     _qCreated :: Int,
     _qSecured :: Int,
     _qDeletedAll :: Int,
+    _qDeletedAllB :: Int,
     _qDeletedNew :: Int,
     _qDeletedSecured :: Int,
     _qSub :: Int,
-    _qSubNoMsg :: Int,
+    _qSubAllB :: Int,
     _qSubAuth :: Int,
     _qSubDuplicate :: Int,
     _qSubProhibited :: Int,
+    _qSubEnd :: Int,
+    _qSubEndB :: Int,
     _ntfCreated :: Int,
     _ntfDeleted :: Int,
+    _ntfDeletedB :: Int,
     _ntfSub :: Int,
+    _ntfSubB :: Int,
     _ntfSubAuth :: Int,
     _ntfSubDuplicate :: Int,
     _msgSent :: Int,
@@ -94,11 +112,10 @@ data ServerStatsData = ServerStatsData
     _msgGetDuplicate :: Int,
     _msgGetProhibited :: Int,
     _msgExpired :: Int,
-    _activeQueues :: PeriodStatsData RecipientId,
-    _subscribedQueues :: PeriodStatsData RecipientId,
+    _activeQueues :: PeriodStatsData,
     _msgSentNtf :: Int,
     _msgRecvNtf :: Int,
-    _activeQueuesNtf :: PeriodStatsData RecipientId,
+    _activeQueuesNtf :: PeriodStatsData,
     _msgNtfs :: Int,
     _msgNtfNoSub :: Int,
     _msgNtfLost :: Int,
@@ -114,65 +131,74 @@ data ServerStatsData = ServerStatsData
 
 newServerStats :: UTCTime -> IO ServerStats
 newServerStats ts = do
-  fromTime <- newTVarIO ts
-  qCreated <- newTVarIO 0
-  qSecured <- newTVarIO 0
-  qDeletedAll <- newTVarIO 0
-  qDeletedNew <- newTVarIO 0
-  qDeletedSecured <- newTVarIO 0
-  qSub <- newTVarIO 0
-  qSubNoMsg <- newTVarIO 0
-  qSubAuth <- newTVarIO 0
-  qSubDuplicate <- newTVarIO 0
-  qSubProhibited <- newTVarIO 0
-  ntfCreated <- newTVarIO 0
-  ntfDeleted <- newTVarIO 0
-  ntfSub <- newTVarIO 0
-  ntfSubAuth <- newTVarIO 0
-  ntfSubDuplicate <- newTVarIO 0
-  msgSent <- newTVarIO 0
-  msgSentAuth <- newTVarIO 0
-  msgSentQuota <- newTVarIO 0
-  msgSentLarge <- newTVarIO 0
-  msgRecv <- newTVarIO 0
-  msgRecvGet <- newTVarIO 0
-  msgGet <- newTVarIO 0
-  msgGetNoMsg <- newTVarIO 0
-  msgGetAuth <- newTVarIO 0
-  msgGetDuplicate <- newTVarIO 0
-  msgGetProhibited <- newTVarIO 0
-  msgExpired <- newTVarIO 0
+  fromTime <- newIORef ts
+  qCreated <- newIORef 0
+  qSecured <- newIORef 0
+  qDeletedAll <- newIORef 0
+  qDeletedAllB <- newIORef 0
+  qDeletedNew <- newIORef 0
+  qDeletedSecured <- newIORef 0
+  qSub <- newIORef 0
+  qSubAllB <- newIORef 0
+  qSubAuth <- newIORef 0
+  qSubDuplicate <- newIORef 0
+  qSubProhibited <- newIORef 0
+  qSubEnd <- newIORef 0
+  qSubEndB <- newIORef 0
+  ntfCreated <- newIORef 0
+  ntfDeleted <- newIORef 0
+  ntfDeletedB <- newIORef 0
+  ntfSub <- newIORef 0
+  ntfSubB <- newIORef 0
+  ntfSubAuth <- newIORef 0
+  ntfSubDuplicate <- newIORef 0
+  msgSent <- newIORef 0
+  msgSentAuth <- newIORef 0
+  msgSentQuota <- newIORef 0
+  msgSentLarge <- newIORef 0
+  msgRecv <- newIORef 0
+  msgRecvGet <- newIORef 0
+  msgGet <- newIORef 0
+  msgGetNoMsg <- newIORef 0
+  msgGetAuth <- newIORef 0
+  msgGetDuplicate <- newIORef 0
+  msgGetProhibited <- newIORef 0
+  msgExpired <- newIORef 0
   activeQueues <- newPeriodStats
-  subscribedQueues <- newPeriodStats
-  msgSentNtf <- newTVarIO 0
-  msgRecvNtf <- newTVarIO 0
+  msgSentNtf <- newIORef 0
+  msgRecvNtf <- newIORef 0
   activeQueuesNtf <- newPeriodStats
-  msgNtfs <- newTVarIO 0
-  msgNtfNoSub <- newTVarIO 0
-  msgNtfLost <- newTVarIO 0
+  msgNtfs <- newIORef 0
+  msgNtfNoSub <- newIORef 0
+  msgNtfLost <- newIORef 0
   pRelays <- newProxyStats
   pRelaysOwn <- newProxyStats
   pMsgFwds <- newProxyStats
   pMsgFwdsOwn <- newProxyStats
-  pMsgFwdsRecv <- newTVarIO 0
-  qCount <- newTVarIO 0
-  msgCount <- newTVarIO 0
+  pMsgFwdsRecv <- newIORef 0
+  qCount <- newIORef 0
+  msgCount <- newIORef 0
   pure
     ServerStats
       { fromTime,
         qCreated,
         qSecured,
         qDeletedAll,
+        qDeletedAllB,
         qDeletedNew,
         qDeletedSecured,
         qSub,
-        qSubNoMsg,
+        qSubAllB,
         qSubAuth,
         qSubDuplicate,
         qSubProhibited,
+        qSubEnd,
+        qSubEndB,
         ntfCreated,
         ntfDeleted,
+        ntfDeletedB,
         ntfSub,
+        ntfSubB,
         ntfSubAuth,
         ntfSubDuplicate,
         msgSent,
@@ -188,7 +214,6 @@ newServerStats ts = do
         msgGetProhibited,
         msgExpired,
         activeQueues,
-        subscribedQueues,
         msgSentNtf,
         msgRecvNtf,
         activeQueuesNtf,
@@ -206,65 +231,74 @@ newServerStats ts = do
 
 getServerStatsData :: ServerStats -> IO ServerStatsData
 getServerStatsData s = do
-  _fromTime <- readTVarIO $ fromTime s
-  _qCreated <- readTVarIO $ qCreated s
-  _qSecured <- readTVarIO $ qSecured s
-  _qDeletedAll <- readTVarIO $ qDeletedAll s
-  _qDeletedNew <- readTVarIO $ qDeletedNew s
-  _qDeletedSecured <- readTVarIO $ qDeletedSecured s
-  _qSub <- readTVarIO $ qSub s
-  _qSubNoMsg <- readTVarIO $ qSubNoMsg s
-  _qSubAuth <- readTVarIO $ qSubAuth s
-  _qSubDuplicate <- readTVarIO $ qSubDuplicate s
-  _qSubProhibited <- readTVarIO $ qSubProhibited s
-  _ntfCreated <- readTVarIO $ ntfCreated s
-  _ntfDeleted <- readTVarIO $ ntfDeleted s
-  _ntfSub <- readTVarIO $ ntfSub s
-  _ntfSubAuth <- readTVarIO $ ntfSubAuth s
-  _ntfSubDuplicate <- readTVarIO $ ntfSubDuplicate s
-  _msgSent <- readTVarIO $ msgSent s
-  _msgSentAuth <- readTVarIO $ msgSentAuth s
-  _msgSentQuota <- readTVarIO $ msgSentQuota s
-  _msgSentLarge <- readTVarIO $ msgSentLarge s
-  _msgRecv <- readTVarIO $ msgRecv s
-  _msgRecvGet <- readTVarIO $ msgRecvGet s
-  _msgGet <- readTVarIO $ msgGet s
-  _msgGetNoMsg <- readTVarIO $ msgGetNoMsg s
-  _msgGetAuth <- readTVarIO $ msgGetAuth s
-  _msgGetDuplicate <- readTVarIO $ msgGetDuplicate s
-  _msgGetProhibited <- readTVarIO $ msgGetProhibited s
-  _msgExpired <- readTVarIO $ msgExpired s
+  _fromTime <- readIORef $ fromTime s
+  _qCreated <- readIORef $ qCreated s
+  _qSecured <- readIORef $ qSecured s
+  _qDeletedAll <- readIORef $ qDeletedAll s
+  _qDeletedAllB <- readIORef $ qDeletedAllB s
+  _qDeletedNew <- readIORef $ qDeletedNew s
+  _qDeletedSecured <- readIORef $ qDeletedSecured s
+  _qSub <- readIORef $ qSub s
+  _qSubAllB <- readIORef $ qSubAllB s
+  _qSubAuth <- readIORef $ qSubAuth s
+  _qSubDuplicate <- readIORef $ qSubDuplicate s
+  _qSubProhibited <- readIORef $ qSubProhibited s
+  _qSubEnd <- readIORef $ qSubEnd s
+  _qSubEndB <- readIORef $ qSubEndB s
+  _ntfCreated <- readIORef $ ntfCreated s
+  _ntfDeleted <- readIORef $ ntfDeleted s
+  _ntfDeletedB <- readIORef $ ntfDeletedB s
+  _ntfSub <- readIORef $ ntfSub s
+  _ntfSubB <- readIORef $ ntfSubB s
+  _ntfSubAuth <- readIORef $ ntfSubAuth s
+  _ntfSubDuplicate <- readIORef $ ntfSubDuplicate s
+  _msgSent <- readIORef $ msgSent s
+  _msgSentAuth <- readIORef $ msgSentAuth s
+  _msgSentQuota <- readIORef $ msgSentQuota s
+  _msgSentLarge <- readIORef $ msgSentLarge s
+  _msgRecv <- readIORef $ msgRecv s
+  _msgRecvGet <- readIORef $ msgRecvGet s
+  _msgGet <- readIORef $ msgGet s
+  _msgGetNoMsg <- readIORef $ msgGetNoMsg s
+  _msgGetAuth <- readIORef $ msgGetAuth s
+  _msgGetDuplicate <- readIORef $ msgGetDuplicate s
+  _msgGetProhibited <- readIORef $ msgGetProhibited s
+  _msgExpired <- readIORef $ msgExpired s
   _activeQueues <- getPeriodStatsData $ activeQueues s
-  _subscribedQueues <- getPeriodStatsData $ subscribedQueues s
-  _msgSentNtf <- readTVarIO $ msgSentNtf s
-  _msgRecvNtf <- readTVarIO $ msgRecvNtf s
+  _msgSentNtf <- readIORef $ msgSentNtf s
+  _msgRecvNtf <- readIORef $ msgRecvNtf s
   _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
-  _msgNtfs <- readTVarIO $ msgNtfs s
-  _msgNtfNoSub <- readTVarIO $ msgNtfNoSub s
-  _msgNtfLost <- readTVarIO $ msgNtfLost s
+  _msgNtfs <- readIORef $ msgNtfs s
+  _msgNtfNoSub <- readIORef $ msgNtfNoSub s
+  _msgNtfLost <- readIORef $ msgNtfLost s
   _pRelays <- getProxyStatsData $ pRelays s
   _pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
   _pMsgFwds <- getProxyStatsData $ pMsgFwds s
   _pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s
-  _pMsgFwdsRecv <- readTVarIO $ pMsgFwdsRecv s
-  _qCount <- readTVarIO $ qCount s
-  _msgCount <- readTVarIO $ msgCount s
+  _pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s
+  _qCount <- readIORef $ qCount s
+  _msgCount <- readIORef $ msgCount s
   pure
     ServerStatsData
       { _fromTime,
         _qCreated,
         _qSecured,
         _qDeletedAll,
+        _qDeletedAllB,
         _qDeletedNew,
         _qDeletedSecured,
         _qSub,
-        _qSubNoMsg,
+        _qSubAllB,
         _qSubAuth,
         _qSubDuplicate,
         _qSubProhibited,
+        _qSubEnd,
+        _qSubEndB,
         _ntfCreated,
         _ntfDeleted,
+        _ntfDeletedB,
         _ntfSub,
+        _ntfSubB,
         _ntfSubAuth,
         _ntfSubDuplicate,
         _msgSent,
@@ -280,7 +314,6 @@ getServerStatsData s = do
         _msgGetProhibited,
         _msgExpired,
         _activeQueues,
-        _subscribedQueues,
         _msgSentNtf,
         _msgRecvNtf,
         _activeQueuesNtf,
@@ -296,51 +329,56 @@ getServerStatsData s = do
         _msgCount
       }
 
-setServerStats :: ServerStats -> ServerStatsData -> STM ()
+-- this function is not thread safe, it is used on server start only
+setServerStats :: ServerStats -> ServerStatsData -> IO ()
 setServerStats s d = do
-  writeTVar (fromTime s) $! _fromTime d
-  writeTVar (qCreated s) $! _qCreated d
-  writeTVar (qSecured s) $! _qSecured d
-  writeTVar (qDeletedAll s) $! _qDeletedAll d
-  writeTVar (qDeletedNew s) $! _qDeletedNew d
-  writeTVar (qDeletedSecured s) $! _qDeletedSecured d
-  writeTVar (qSub s) $! _qSub d
-  writeTVar (qSubNoMsg s) $! _qSubNoMsg d
-  writeTVar (qSubAuth s) $! _qSubAuth d
-  writeTVar (qSubDuplicate s) $! _qSubDuplicate d
-  writeTVar (qSubProhibited s) $! _qSubProhibited d
-  writeTVar (ntfCreated s) $! _ntfCreated d
-  writeTVar (ntfDeleted s) $! _ntfDeleted d
-  writeTVar (ntfSub s) $! _ntfSub d
-  writeTVar (ntfSubAuth s) $! _ntfSubAuth d
-  writeTVar (ntfSubDuplicate s) $! _ntfSubDuplicate d
-  writeTVar (msgSent s) $! _msgSent d
-  writeTVar (msgSentAuth s) $! _msgSentAuth d
-  writeTVar (msgSentQuota s) $! _msgSentQuota d
-  writeTVar (msgSentLarge s) $! _msgSentLarge d
-  writeTVar (msgRecv s) $! _msgRecv d
-  writeTVar (msgRecvGet s) $! _msgRecvGet d
-  writeTVar (msgGet s) $! _msgGet d
-  writeTVar (msgGetNoMsg s) $! _msgGetNoMsg d
-  writeTVar (msgGetAuth s) $! _msgGetAuth d
-  writeTVar (msgGetDuplicate s) $! _msgGetDuplicate d
-  writeTVar (msgGetProhibited s) $! _msgGetProhibited d
-  writeTVar (msgExpired s) $! _msgExpired d
+  writeIORef (fromTime s) $! _fromTime d
+  writeIORef (qCreated s) $! _qCreated d
+  writeIORef (qSecured s) $! _qSecured d
+  writeIORef (qDeletedAll s) $! _qDeletedAll d
+  writeIORef (qDeletedAllB s) $! _qDeletedAllB d
+  writeIORef (qDeletedNew s) $! _qDeletedNew d
+  writeIORef (qDeletedSecured s) $! _qDeletedSecured d
+  writeIORef (qSub s) $! _qSub d
+  writeIORef (qSubAllB s) $! _qSubAllB d
+  writeIORef (qSubAuth s) $! _qSubAuth d
+  writeIORef (qSubDuplicate s) $! _qSubDuplicate d
+  writeIORef (qSubProhibited s) $! _qSubProhibited d
+  writeIORef (qSubEnd s) $! _qSubEnd d
+  writeIORef (qSubEndB s) $! _qSubEndB d
+  writeIORef (ntfCreated s) $! _ntfCreated d
+  writeIORef (ntfDeleted s) $! _ntfDeleted d
+  writeIORef (ntfDeletedB s) $! _ntfDeletedB d
+  writeIORef (ntfSub s) $! _ntfSub d
+  writeIORef (ntfSubB s) $! _ntfSubB d
+  writeIORef (ntfSubAuth s) $! _ntfSubAuth d
+  writeIORef (ntfSubDuplicate s) $! _ntfSubDuplicate d
+  writeIORef (msgSent s) $! _msgSent d
+  writeIORef (msgSentAuth s) $! _msgSentAuth d
+  writeIORef (msgSentQuota s) $! _msgSentQuota d
+  writeIORef (msgSentLarge s) $! _msgSentLarge d
+  writeIORef (msgRecv s) $! _msgRecv d
+  writeIORef (msgRecvGet s) $! _msgRecvGet d
+  writeIORef (msgGet s) $! _msgGet d
+  writeIORef (msgGetNoMsg s) $! _msgGetNoMsg d
+  writeIORef (msgGetAuth s) $! _msgGetAuth d
+  writeIORef (msgGetDuplicate s) $! _msgGetDuplicate d
+  writeIORef (msgGetProhibited s) $! _msgGetProhibited d
+  writeIORef (msgExpired s) $! _msgExpired d
   setPeriodStats (activeQueues s) (_activeQueues d)
-  setPeriodStats (subscribedQueues s) (_subscribedQueues d)
-  writeTVar (msgSentNtf s) $! _msgSentNtf d
-  writeTVar (msgRecvNtf s) $! _msgRecvNtf d
+  writeIORef (msgSentNtf s) $! _msgSentNtf d
+  writeIORef (msgRecvNtf s) $! _msgRecvNtf d
   setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
-  writeTVar (msgNtfs s) $! _msgNtfs d
-  writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d
-  writeTVar (msgNtfLost s) $! _msgNtfLost d
+  writeIORef (msgNtfs s) $! _msgNtfs d
+  writeIORef (msgNtfNoSub s) $! _msgNtfNoSub d
+  writeIORef (msgNtfLost s) $! _msgNtfLost d
   setProxyStats (pRelays s) $! _pRelays d
   setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
   setProxyStats (pMsgFwds s) $! _pMsgFwds d
   setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d
-  writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
-  writeTVar (qCount s) $! _qCount d
-  writeTVar (msgCount s) $! _msgCount d
+  writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
+  writeIORef (qCount s) $! _qCount d
+  writeIORef (msgCount s) $! _msgCount d
 
 instance StrEncoding ServerStatsData where
   strEncode d =
@@ -351,15 +389,20 @@ instance StrEncoding ServerStatsData where
         "qDeletedAll=" <> strEncode (_qDeletedAll d),
         "qDeletedNew=" <> strEncode (_qDeletedNew d),
         "qDeletedSecured=" <> strEncode (_qDeletedSecured d),
+        "qDeletedAllB=" <> strEncode (_qDeletedAllB d),
         "qCount=" <> strEncode (_qCount d),
         "qSub=" <> strEncode (_qSub d),
-        "qSubNoMsg=" <> strEncode (_qSubNoMsg d),
+        "qSubAllB=" <> strEncode (_qSubAllB d),
         "qSubAuth=" <> strEncode (_qSubAuth d),
         "qSubDuplicate=" <> strEncode (_qSubDuplicate d),
         "qSubProhibited=" <> strEncode (_qSubProhibited d),
+        "qSubEnd=" <> strEncode (_qSubEnd d),
+        "qSubEndB=" <> strEncode (_qSubEndB d),
         "ntfCreated=" <> strEncode (_ntfCreated d),
         "ntfDeleted=" <> strEncode (_ntfDeleted d),
+        "ntfDeletedB=" <> strEncode (_ntfDeletedB d),
         "ntfSub=" <> strEncode (_ntfSub d),
+        "ntfSubB=" <> strEncode (_ntfSubB d),
         "ntfSubAuth=" <> strEncode (_ntfSubAuth d),
         "ntfSubDuplicate=" <> strEncode (_ntfSubDuplicate d),
         "msgSent=" <> strEncode (_msgSent d),
@@ -381,8 +424,6 @@ instance StrEncoding ServerStatsData where
         "msgNtfLost=" <> strEncode (_msgNtfLost d),
         "activeQueues:",
         strEncode (_activeQueues d),
-        "subscribedQueues:",
-        strEncode (_subscribedQueues d),
         "activeQueuesNtf:",
         strEncode (_activeQueuesNtf d),
         "pRelays:",
@@ -402,15 +443,21 @@ instance StrEncoding ServerStatsData where
     (_qDeletedAll, _qDeletedNew, _qDeletedSecured) <-
       (,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine)
         <|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine))
+    _qDeletedAllB <- opt "qDeletedAllB="
     _qCount <- opt "qCount="
     _qSub <- opt "qSub="
-    _qSubNoMsg <- opt "qSubNoMsg="
+    _qSubNoMsg <- skipInt "qSubNoMsg=" -- skipping it for backward compatibility
+    _qSubAllB <- opt "qSubAllB="
     _qSubAuth <- opt "qSubAuth="
     _qSubDuplicate <- opt "qSubDuplicate="
     _qSubProhibited <- opt "qSubProhibited="
+    _qSubEnd <- opt "qSubEnd="
+    _qSubEndB <- opt "qSubEndB="
     _ntfCreated <- opt "ntfCreated="
     _ntfDeleted <- opt "ntfDeleted="
+    _ntfDeletedB <- opt "ntfDeletedB="
     _ntfSub <- opt "ntfSub="
+    _ntfSubB <- opt "ntfSubB="
     _ntfSubAuth <- opt "ntfSubAuth="
     _ntfSubDuplicate <- opt "ntfSubDuplicate="
     _msgSent <- "msgSent=" *> strP <* A.endOfLine
@@ -440,7 +487,7 @@ instance StrEncoding ServerStatsData where
           pure PeriodStatsData {_day, _week, _month}
     _subscribedQueues <-
       optional ("subscribedQueues:" <* A.endOfLine) >>= \case
-        Just _ -> strP <* optional A.endOfLine
+        Just _ -> newPeriodStatsData <$ (strP @PeriodStatsData <* optional A.endOfLine)
         _ -> pure newPeriodStatsData
     _activeQueuesNtf <-
       optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
@@ -457,16 +504,21 @@ instance StrEncoding ServerStatsData where
           _qCreated,
           _qSecured,
           _qDeletedAll,
+          _qDeletedAllB,
           _qDeletedNew,
           _qDeletedSecured,
           _qSub,
-          _qSubNoMsg,
+          _qSubAllB,
           _qSubAuth,
           _qSubDuplicate,
           _qSubProhibited,
+          _qSubEnd,
+          _qSubEndB,
           _ntfCreated,
           _ntfDeleted,
+          _ntfDeletedB,
           _ntfSub,
+          _ntfSubB,
           _ntfSubAuth,
           _ntfSubDuplicate,
           _msgSent,
@@ -487,7 +539,6 @@ instance StrEncoding ServerStatsData where
           _msgNtfNoSub,
           _msgNtfLost,
           _activeQueues,
-          _subscribedQueues,
           _activeQueuesNtf,
           _pRelays,
           _pRelaysOwn,
@@ -499,55 +550,59 @@ instance StrEncoding ServerStatsData where
         }
     where
       opt s = A.string s *> strP <* A.endOfLine <|> pure 0
+      skipInt s = (0 :: Int) <$ optional (A.string s *> strP @Int *> A.endOfLine)
       proxyStatsP key =
         optional (A.string key >> A.endOfLine) >>= \case
           Just _ -> strP <* optional A.endOfLine
           _ -> pure newProxyStatsData
 
-data PeriodStats a = PeriodStats
-  { day :: TVar (Set a),
-    week :: TVar (Set a),
-    month :: TVar (Set a)
+data PeriodStats = PeriodStats
+  { day :: IORef IntSet,
+    week :: IORef IntSet,
+    month :: IORef IntSet
   }
 
-newPeriodStats :: IO (PeriodStats a)
+newPeriodStats :: IO PeriodStats
 newPeriodStats = do
-  day <- newTVarIO S.empty
-  week <- newTVarIO S.empty
-  month <- newTVarIO S.empty
+  day <- newIORef IS.empty
+  week <- newIORef IS.empty
+  month <- newIORef IS.empty
   pure PeriodStats {day, week, month}
 
-data PeriodStatsData a = PeriodStatsData
-  { _day :: Set a,
-    _week :: Set a,
-    _month :: Set a
+data PeriodStatsData = PeriodStatsData
+  { _day :: IntSet,
+    _week :: IntSet,
+    _month :: IntSet
   }
   deriving (Show)
 
-newPeriodStatsData :: PeriodStatsData a
-newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty}
+newPeriodStatsData :: PeriodStatsData
+newPeriodStatsData = PeriodStatsData {_day = IS.empty, _week = IS.empty, _month = IS.empty}
 
-getPeriodStatsData :: PeriodStats a -> IO (PeriodStatsData a)
+getPeriodStatsData :: PeriodStats -> IO PeriodStatsData
 getPeriodStatsData s = do
-  _day <- readTVarIO $ day s
-  _week <- readTVarIO $ week s
-  _month <- readTVarIO $ month s
+  _day <- readIORef $ day s
+  _week <- readIORef $ week s
+  _month <- readIORef $ month s
   pure PeriodStatsData {_day, _week, _month}
 
-setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
+-- this function is not thread safe, it is used on server start only
+setPeriodStats :: PeriodStats -> PeriodStatsData -> IO ()
 setPeriodStats s d = do
-  writeTVar (day s) $! _day d
-  writeTVar (week s) $! _week d
-  writeTVar (month s) $! _month d
+  writeIORef (day s) $! _day d
+  writeIORef (week s) $! _week d
+  writeIORef (month s) $! _month d
 
-instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
+instance StrEncoding PeriodStatsData where
   strEncode PeriodStatsData {_day, _week, _month} =
-    "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
+    "dayHashes=" <> strEncode _day <> "\nweekHashes=" <> strEncode _week <> "\nmonthHashes=" <> strEncode _month
   strP = do
-    _day <- "day=" *> strP <* A.endOfLine
-    _week <- "week=" *> strP <* A.endOfLine
-    _month <- "month=" *> strP
+    _day <- ("day=" *> bsSetP <|> "dayHashes=" *> strP) <* A.endOfLine
+    _week <- ("week=" *> bsSetP <|> "weekHashes=" *> strP) <* A.endOfLine
+    _month <- "month=" *> bsSetP <|> "monthHashes=" *> strP
     pure PeriodStatsData {_day, _week, _month}
+    where
+      bsSetP = S.foldl' (\s -> (`IS.insert` s) . hash) IS.empty <$> strP @(Set ByteString)
 
 data PeriodStatCounts = PeriodStatCounts
   { dayCount :: String,
@@ -555,7 +610,7 @@ data PeriodStatCounts = PeriodStatCounts
     monthCount :: String
   }
 
-periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
+periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts
 periodStatCounts ps ts = do
   let d = utctDay ts
       (_, wDay) = mondayStartWeek d
@@ -565,33 +620,34 @@ periodStatCounts ps ts = do
   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 :: Int -> IORef IntSet -> IO String
+    periodCount 1 ref = show . IS.size <$> atomicSwapIORef ref IS.empty
     periodCount _ _ = pure ""
 
-updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
-updatePeriodStats stats pId = do
-  updatePeriod day
-  updatePeriod week
-  updatePeriod month
+updatePeriodStats :: PeriodStats -> EntityId -> IO ()
+updatePeriodStats ps (EntityId pId) = do
+  updatePeriod $ day ps
+  updatePeriod $ week ps
+  updatePeriod $ month ps
   where
-    updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)
+    ph = hash pId
+    updatePeriod ref = unlessM (IS.member ph <$> readIORef ref) $ atomicModifyIORef'_ ref $ IS.insert ph
 
 data ProxyStats = ProxyStats
-  { pRequests :: TVar Int,
-    pSuccesses :: TVar Int, -- includes destination server error responses that will be forwarded to the client
-    pErrorsConnect :: TVar Int,
-    pErrorsCompat :: TVar Int,
-    pErrorsOther :: TVar Int
+  { pRequests :: IORef Int,
+    pSuccesses :: IORef Int, -- includes destination server error responses that will be forwarded to the client
+    pErrorsConnect :: IORef Int,
+    pErrorsCompat :: IORef Int,
+    pErrorsOther :: IORef Int
   }
 
 newProxyStats :: IO ProxyStats
 newProxyStats = do
-  pRequests <- newTVarIO 0
-  pSuccesses <- newTVarIO 0
-  pErrorsConnect <- newTVarIO 0
-  pErrorsCompat <- newTVarIO 0
-  pErrorsOther <- newTVarIO 0
+  pRequests <- newIORef 0
+  pSuccesses <- newIORef 0
+  pErrorsConnect <- newIORef 0
+  pErrorsCompat <- newIORef 0
+  pErrorsOther <- newIORef 0
   pure ProxyStats {pRequests, pSuccesses, pErrorsConnect, pErrorsCompat, pErrorsOther}
 
 data ProxyStatsData = ProxyStatsData
@@ -608,29 +664,30 @@ newProxyStatsData = ProxyStatsData {_pRequests = 0, _pSuccesses = 0, _pErrorsCon
 
 getProxyStatsData :: ProxyStats -> IO ProxyStatsData
 getProxyStatsData s = do
-  _pRequests <- readTVarIO $ pRequests s
-  _pSuccesses <- readTVarIO $ pSuccesses s
-  _pErrorsConnect <- readTVarIO $ pErrorsConnect s
-  _pErrorsCompat <- readTVarIO $ pErrorsCompat s
-  _pErrorsOther <- readTVarIO $ pErrorsOther s
+  _pRequests <- readIORef $ pRequests s
+  _pSuccesses <- readIORef $ pSuccesses s
+  _pErrorsConnect <- readIORef $ pErrorsConnect s
+  _pErrorsCompat <- readIORef $ pErrorsCompat s
+  _pErrorsOther <- readIORef $ pErrorsOther s
   pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
 
-getResetProxyStatsData :: ProxyStats -> STM ProxyStatsData
+getResetProxyStatsData :: ProxyStats -> IO ProxyStatsData
 getResetProxyStatsData s = do
-  _pRequests <- swapTVar (pRequests s) 0
-  _pSuccesses <- swapTVar (pSuccesses s) 0
-  _pErrorsConnect <- swapTVar (pErrorsConnect s) 0
-  _pErrorsCompat <- swapTVar (pErrorsCompat s) 0
-  _pErrorsOther <- swapTVar (pErrorsOther s) 0
+  _pRequests <- atomicSwapIORef (pRequests s) 0
+  _pSuccesses <- atomicSwapIORef (pSuccesses s) 0
+  _pErrorsConnect <- atomicSwapIORef (pErrorsConnect s) 0
+  _pErrorsCompat <- atomicSwapIORef (pErrorsCompat s) 0
+  _pErrorsOther <- atomicSwapIORef (pErrorsOther s) 0
   pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
 
-setProxyStats :: ProxyStats -> ProxyStatsData -> STM ()
+-- this function is not thread safe, it is used on server start only
+setProxyStats :: ProxyStats -> ProxyStatsData -> IO ()
 setProxyStats s d = do
-  writeTVar (pRequests s) $! _pRequests d
-  writeTVar (pSuccesses s) $! _pSuccesses d
-  writeTVar (pErrorsConnect s) $! _pErrorsConnect d
-  writeTVar (pErrorsCompat s) $! _pErrorsCompat d
-  writeTVar (pErrorsOther s) $! _pErrorsOther d
+  writeIORef (pRequests s) $! _pRequests d
+  writeIORef (pSuccesses s) $! _pSuccesses d
+  writeIORef (pErrorsConnect s) $! _pErrorsConnect d
+  writeIORef (pErrorsCompat s) $! _pErrorsCompat d
+  writeIORef (pErrorsOther s) $! _pErrorsOther d
 
 instance StrEncoding ProxyStatsData where
   strEncode ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} =

src/Simplex/Messaging/Server/StoreLog.hs

@@ -20,12 +20,14 @@ module Simplex.Messaging.Server.StoreLog
     logSuspendQueue,
     logDeleteQueue,
     logDeleteNotifier,
+    logUpdateQueueTime,
     readWriteStoreLog,
   )
 where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad (foldM, unless, when)
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
@@ -33,10 +35,10 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
+import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Util (ifM)
-import System.Directory (doesFileExist)
+import System.Directory (doesFileExist, renameFile)
 import System.IO
 
 -- | opaque container for file handle with a type-safe IOMode
@@ -52,9 +54,19 @@ data StoreLogRecord
   | SuspendQueue QueueId
   | DeleteQueue QueueId
   | DeleteNotifier QueueId
+  | UpdateTime QueueId RoundedSystemTime
+
+data SLRTag
+  = CreateQueue_
+  | SecureQueue_
+  | AddNotifier_
+  | SuspendQueue_
+  | DeleteQueue_
+  | DeleteNotifier_
+  | UpdateTime_
 
 instance StrEncoding QueueRec where
-  strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} =
+  strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} =
     B.unwords
       [ "rid=" <> strEncode recipientId,
         "rk=" <> strEncode recipientKey,
@@ -64,8 +76,10 @@ instance StrEncoding QueueRec where
       ]
       <> if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
       <> maybe "" notifierStr notifier
+      <> maybe "" updatedAtStr updatedAt
     where
       notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
+      updatedAtStr t = " updated_at=" <> strEncode t
 
   strP = do
     recipientId <- "rid=" *> strP_
@@ -75,24 +89,49 @@ instance StrEncoding QueueRec where
     senderKey <- "sk=" *> strP
     sndSecure <- (" sndSecure=" *> strP) <|> pure False
     notifier <- optional $ " notifier=" *> strP
-    pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive}
+    updatedAt <- optional $ " updated_at=" *> strP
+    pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt}
+
+instance StrEncoding SLRTag where
+  strEncode = \case
+    CreateQueue_ -> "CREATE"
+    SecureQueue_ -> "SECURE"
+    AddNotifier_ -> "NOTIFIER"
+    SuspendQueue_ -> "SUSPEND"
+    DeleteQueue_ -> "DELETE"
+    DeleteNotifier_ -> "NDELETE"
+    UpdateTime_ -> "TIME"
+
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "CREATE" -> pure CreateQueue_
+      "SECURE" -> pure SecureQueue_
+      "NOTIFIER" -> pure AddNotifier_
+      "SUSPEND" -> pure SuspendQueue_
+      "DELETE" -> pure DeleteQueue_
+      "NDELETE" -> pure DeleteNotifier_
+      "TIME" -> pure UpdateTime_
+      s -> fail $ "invalid log record tag: " <> B.unpack s
 
 instance StrEncoding StoreLogRecord where
   strEncode = \case
-    CreateQueue q -> strEncode (Str "CREATE", q)
-    SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)
-    AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds)
-    SuspendQueue rId -> strEncode (Str "SUSPEND", rId)
-    DeleteQueue rId -> strEncode (Str "DELETE", rId)
-    DeleteNotifier rId -> strEncode (Str "NDELETE", rId)
+    CreateQueue q -> strEncode (CreateQueue_, q)
+    SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey)
+    AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds)
+    SuspendQueue rId -> strEncode (SuspendQueue_, rId)
+    DeleteQueue rId -> strEncode (DeleteQueue_, rId)
+    DeleteNotifier rId -> strEncode (DeleteNotifier_, rId)
+    UpdateTime rId t ->  strEncode (UpdateTime_, rId, t)
 
   strP =
-    "CREATE " *> (CreateQueue <$> strP)
-      <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
-      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP)
-      <|> "SUSPEND " *> (SuspendQueue <$> strP)
-      <|> "DELETE " *> (DeleteQueue <$> strP)
-      <|> "NDELETE " *> (DeleteNotifier <$> strP)
+    strP_ >>= \case
+      CreateQueue_ -> CreateQueue <$> strP
+      SecureQueue_ -> SecureQueue <$> strP_ <*> strP
+      AddNotifier_ -> AddNotifier <$> strP_ <*> strP
+      SuspendQueue_ -> SuspendQueue <$> strP
+      DeleteQueue_ -> DeleteQueue <$> strP
+      DeleteNotifier_ -> DeleteNotifier <$> strP
+      UpdateTime_ -> UpdateTime <$> strP_ <*> strP
 
 openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
 openWriteStoreLog f = do
@@ -138,12 +177,17 @@ logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
 logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
 logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
 
+logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
+logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t
+
 readWriteStoreLog :: FilePath -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
 readWriteStoreLog f = do
-  qs <- ifM (doesFileExist f) (readQueues f) (pure M.empty)
+  qs <- ifM (doesFileExist f) readQS (pure M.empty)
   s <- openWriteStoreLog f
   writeQueues s qs
   pure (qs, s)
+  where
+    readQS = readQueues f <* renameFile f (f <> ".bak")
 
 writeQueues :: StoreLog 'WriteMode -> Map RecipientId QueueRec -> IO ()
 writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q
@@ -167,5 +211,6 @@ readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f
           SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
           DeleteQueue qId -> M.delete qId m
           DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
+          UpdateTime qId t -> M.adjust (\q -> q {updatedAt = Just t}) qId m
         printError :: String -> IO ()
         printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

src/Simplex/Messaging/Transport.hs

@@ -47,6 +47,7 @@ module Simplex.Messaging.Transport
     authCmdsSMPVersion,
     sendingProxySMPVersion,
     sndAuthKeySMPVersion,
+    deletedEventSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -71,6 +72,7 @@ module Simplex.Messaging.Transport
     THandle (..),
     THandleParams (..),
     THandleAuth (..),
+    TSbChainKeys (..),
     TransportError (..),
     HandshakeError (..),
     smpServerHandshake,
@@ -84,6 +86,7 @@ module Simplex.Messaging.Transport
 where
 
 import Control.Applicative (optional)
+import Control.Concurrent.STM
 import Control.Monad (forM, (<$!>))
 import Control.Monad.Except
 import Control.Monad.Trans.Except (throwE)
@@ -113,9 +116,9 @@ import Simplex.Messaging.Transport.Buffer
 import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
+import System.IO.Error (isEOFError)
 import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
-import UnliftIO.STM
 
 -- * Transport parameters
 
@@ -130,6 +133,9 @@ smpBlockSize = 16384
 -- 5 - basic auth for SMP servers (11/12/2022)
 -- 6 - allow creating queues without subscribing (9/10/2023)
 -- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
+-- 8 - SMP proxy for sender commands
+-- 9 - faster handshake: SKEY command for sender to secure queue
+-- 10 - DELD event to subscriber when queue is deleted via another connnection
 
 data SMPVersion
 
@@ -160,14 +166,17 @@ sendingProxySMPVersion = VersionSMP 8
 sndAuthKeySMPVersion :: VersionSMP
 sndAuthKeySMPVersion = VersionSMP 9
 
+deletedEventSMPVersion :: VersionSMP
+deletedEventSMPVersion = VersionSMP 10
+
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 9
+currentClientSMPRelayVersion = VersionSMP 10
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 9
+currentServerSMPRelayVersion = VersionSMP 10
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -339,11 +348,12 @@ instance Transport TLS where
 
   getLn :: TLS -> IO ByteString
   getLn TLS {tlsContext, tlsBuffer} = do
-    getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catch` handleEOF
+    getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
     where
-      handleEOF = \case
-        T.Error_EOF -> E.throwIO TEBadBlock
+      handleTlsEOF = \case
+        T.PostHandshake T.Error_EOF -> E.throwIO TEBadBlock
         e -> E.throwIO e
+      handleEOF e = if isEOFError e then E.throwIO TEBadBlock else E.throwIO e
 
 -- * SMP transport
 
@@ -385,6 +395,11 @@ data THandleAuth (p :: TransportPeer) where
     } ->
     THandleAuth 'TServer
 
+data TSbChainKeys = TSbChainKeys
+  { sndKey :: TVar C.SbChainKey,
+    rcvKey :: TVar C.SbChainKey
+  }
+
 -- | TLS-unique channel binding
 type SessionId = ByteString
 

src/Simplex/Messaging/Transport/Client.hs

@@ -13,9 +13,13 @@ module Simplex.Messaging.Transport.Client
     defaultSMPPort,
     defaultTcpConnectTimeout,
     defaultTransportClientConfig,
+    defaultSocksProxyWithAuth,
     defaultSocksProxy,
+    defaultSocksHost,
     TransportClientConfig (..),
-    SocksProxy,
+    SocksProxy (..),
+    SocksProxyWithAuth (..),
+    SocksAuth (..),
     TransportHost (..),
     TransportHosts (..),
     TransportHosts_ (..),
@@ -23,7 +27,7 @@ module Simplex.Messaging.Transport.Client
   )
 where
 
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
 import Control.Logger.Simple (logError)
 import Control.Monad (when)
 import Data.Aeson (FromJSON (..), ToJSON (..))
@@ -79,7 +83,7 @@ instance StrEncoding TransportHost where
   strP =
     A.choice
       [ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
-        maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> A.takeWhile1 (\c -> isHexDigit c || c == ':'),
+        maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> ipv6StrP,
         THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
         THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
       ]
@@ -87,6 +91,9 @@ instance StrEncoding TransportHost where
       ipNum = validIP <$?> (A.decimal <* A.char '.')
       validIP :: Int -> Either String Word8
       validIP n = if 0 <= n && n <= 255 then Right $ fromIntegral n else Left "invalid IP address"
+      ipv6StrP =
+        A.char '[' *> A.takeWhile1 (/= ']') <* A.char ']'
+          <|> A.takeWhile1 (\c -> isHexDigit c || c == ':')
       notOnion s = if ".onion" `B.isSuffixOf` s then Left "invalid onion host" else Right s
 
 instance ToJSON TransportHost where
@@ -134,16 +141,16 @@ clientTransportConfig TransportClientConfig {logTLSErrors} =
   TransportConfig {logTLSErrors, transportTimeout = Nothing}
 
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
+runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
 runTransportClient = runTLSTransportClient supportedParameters Nothing
 
-runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
-runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do
+runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
+runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} socksCreds host port keyHash client = do
   serverCert <- newEmptyTMVarIO
   let hostName = B.unpack $ strEncode host
       clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
       connectTCP = case socksProxy of
-        Just proxy -> connectSocksClient proxy proxyUsername (hostAddr host)
+        Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
         _ -> connectTCPClient hostName
   c <- do
     sock <- connectTCP port
@@ -191,40 +198,70 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
 defaultSMPPort :: PortNumber
 defaultSMPPort = 5223
 
-connectSocksClient :: SocksProxy -> Maybe ByteString -> SocksHostAddress -> ServiceName -> IO Socket
-connectSocksClient (SocksProxy addr) proxyUsername hostAddr _port = do
+connectSocksClient :: SocksProxy -> Maybe SocksCredentials -> SocksHostAddress -> ServiceName -> IO Socket
+connectSocksClient (SocksProxy addr) socksCreds hostAddr _port = do
   let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
-  fst <$> case proxyUsername of
-    Just username -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) (SocksCredentials username "")
+  fst <$> case socksCreds of
+    Just creds -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) creds
     _ -> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
 
-defaultSocksHost :: HostAddress
-defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
+defaultSocksHost :: (Word8, Word8, Word8, Word8)
+defaultSocksHost = (127, 0, 0, 1)
+
+defaultSocksProxyWithAuth :: SocksProxyWithAuth
+defaultSocksProxyWithAuth = SocksProxyWithAuth SocksIsolateByAuth defaultSocksProxy
 
 defaultSocksProxy :: SocksProxy
-defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
+defaultSocksProxy = SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress defaultSocksHost
 
 newtype SocksProxy = SocksProxy SockAddr
   deriving (Eq)
 
+data SocksProxyWithAuth = SocksProxyWithAuth SocksAuth SocksProxy
+  deriving (Eq, Show)
+
+data SocksAuth
+  = SocksAuthUsername {username :: ByteString, password :: ByteString}
+  | SocksAuthNull
+  | SocksIsolateByAuth -- this is default
+  deriving (Eq, Show)
+
 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
+    host <- fromMaybe (THIPv4 defaultSocksHost) <$> optional strP
     port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
-    pure . SocksProxy $ SockAddrInet port host
+    SocksProxy <$> socksAddr port host
     where
-      ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
-      ipNum = A.decimal <* A.char '.'
+      socksAddr port = \case
+        THIPv4 addr -> pure $ SockAddrInet port $ tupleToHostAddress addr
+        THIPv6 addr -> pure $ SockAddrInet6 port 0 addr 0
+        _ -> fail "SOCKS5 host should be IPv4 or IPv6 address"          
 
-instance ToJSON SocksProxy where
+instance StrEncoding SocksProxyWithAuth where
+  strEncode (SocksProxyWithAuth auth proxy) = strEncode auth <> strEncode proxy
+  strP = SocksProxyWithAuth <$> strP <*> strP
+
+instance ToJSON SocksProxyWithAuth where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-instance FromJSON SocksProxy where
-  parseJSON = strParseJSON "SocksProxy"
+instance FromJSON SocksProxyWithAuth where
+  parseJSON = strParseJSON "SocksProxyWithAuth"
+
+instance StrEncoding SocksAuth where
+  strEncode = \case
+    SocksAuthUsername {username, password} -> username <> ":" <> password <> "@"
+    SocksAuthNull -> "@"
+    SocksIsolateByAuth -> ""
+  strP = usernameP <|> (SocksAuthNull <$ A.char '@') <|> pure SocksIsolateByAuth
+    where
+      usernameP = do
+        username <- A.takeTill (== ':') <* A.char ':'
+        password <- A.takeTill (== '@') <* A.char '@'
+        pure SocksAuthUsername {username, password}
 
 mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> TMVar X.CertificateChain -> T.ClientParams
 mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts =

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -2,7 +2,6 @@
 
 module Simplex.Messaging.Transport.HTTP2 where
 
-import Control.Concurrent.STM
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B

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

@@ -11,7 +11,6 @@ import Control.Concurrent.Async
 import Control.Exception (IOException, try)
 import qualified Control.Exception as E
 import Control.Monad
-import Data.ByteString.Char8 (ByteString)
 import Data.Functor (($>))
 import Data.Time (UTCTime, getCurrentTime)
 import qualified Data.X509 as X
@@ -20,6 +19,7 @@ import Network.HPACK (BufferSize)
 import Network.HTTP2.Client (ClientConfig (..), Request, Response)
 import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
+import Network.Socks5 (SocksCredentials)
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
 import qualified Simplex.Messaging.Crypto as C
@@ -91,10 +91,10 @@ data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOExcepti
 getHTTP2Client :: HostName -> ServiceName -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
 getHTTP2Client host port = getVerifiedHTTP2Client Nothing (THDomainName host) port Nothing
 
-getVerifiedHTTP2Client :: Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getVerifiedHTTP2Client proxyUsername host port keyHash caStore config disconnected = getVerifiedHTTP2ClientWith config host port disconnected setup
+getVerifiedHTTP2Client :: Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+getVerifiedHTTP2Client socksCreds host port keyHash caStore config disconnected = getVerifiedHTTP2ClientWith config host port disconnected setup
   where
-    setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) proxyUsername host port keyHash
+    setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) socksCreds host port keyHash
 
 attachHTTP2Client :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
 attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup
@@ -178,11 +178,11 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
 http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
 http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
 
-runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
-runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash = runHTTP2ClientWith bufferSize host setup
+runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
+runHTTP2Client tlsParams caStore tcConfig bufferSize socksCreds host port keyHash = runHTTP2ClientWith bufferSize host setup
   where
     setup :: (TLS -> IO a) -> IO a
-    setup = runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash
+    setup = runTLSTransportClient tlsParams caStore tcConfig socksCreds host port keyHash
 
 runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (TLS -> H.Client a) -> IO a
 runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls

src/Simplex/Messaging/Transport/Server.hs

@@ -12,7 +12,7 @@ module Simplex.Messaging.Transport.Server
     newSocketState,
     runTransportServer,
     runTransportServerSocket,
-    runTCPServer,
+    runLocalTCPServer,
     runTCPServerSocket,
     startTCPServer,
     loadSupportedTLSServerParams,
@@ -80,7 +80,7 @@ runTransportServer started port params cfg server = do
   runTransportServerState ss started port params cfg server
 
 runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO ()
-runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c))
+runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c))
 
 -- | Run a transport server with provided connection setup and handler.
 runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
@@ -107,10 +107,10 @@ tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared se
   _ -> error "server has more than one key"
 
 -- | Run TCP server without TLS
-runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
-runTCPServer started port server = do
+runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
+runLocalTCPServer started port server = do
   ss <- newSocketState
-  runTCPServerSocket ss started (startTCPServer started port) server
+  runTCPServerSocket ss started (startTCPServer started (Just "127.0.0.1") port) server
 
 -- | Wrap socket provider in a TCP server bracket.
 runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO ()
@@ -157,12 +157,12 @@ closeServer started clients sock = do
   close sock
   void . atomically $ tryPutTMVar started False
 
-startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
-startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
+startTCPServer :: TMVar Bool -> Maybe HostName -> ServiceName -> IO Socket
+startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStarted
   where
     resolve =
       let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
-       in select <$> getAddrInfo (Just hints) Nothing (Just port)
+       in select <$> getAddrInfo (Just hints) host (Just port)
     select as = fromJust $ family AF_INET6 <|> family AF_INET
       where
         family f = find ((== f) . addrFamily) as

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -25,6 +25,7 @@ import Simplex.Messaging.Transport
     withTlsUnique,
   )
 import Simplex.Messaging.Transport.Buffer (trimCR)
+import System.IO.Error (isEOFError)
 
 data WS = WS
   { wsPeer :: TransportPeer,
@@ -108,9 +109,11 @@ makeTLSContextStream cxt =
   S.makeStream readStream writeStream
   where
     readStream :: IO (Maybe ByteString)
-    readStream =
-      (Just <$> T.recvData cxt) `E.catch` \case
-        T.Error_EOF -> pure Nothing
-        e -> E.throwIO e
+    readStream = (Just <$> T.recvData cxt) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
+      where
+        handleTlsEOF = \case
+          T.PostHandshake T.Error_EOF -> pure Nothing
+          e -> E.throwIO e
+        handleEOF e = if isEOFError e then pure Nothing else E.throwIO e
     writeStream :: Maybe LB.ByteString -> IO ()
     writeStream = maybe (closeTLS cxt) (T.sendData cxt)

src/Simplex/Messaging/Util.hs

@@ -15,6 +15,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.IORef
 import Data.List (groupBy, sortOn)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
@@ -23,7 +24,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
 import Data.Time (NominalDiffTime)
 import GHC.Conc (labelThread, myThreadId, threadDelay)
-import UnliftIO
+import UnliftIO hiding (atomicModifyIORef')
 import qualified UnliftIO.Exception as UE
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -166,14 +167,19 @@ threadDelay' = loop
           loop $ time - maxWait
 
 diffToMicroseconds :: NominalDiffTime -> Int64
-diffToMicroseconds diff = fromIntegral ((truncate $ diff * 1000000) :: Integer)
+diffToMicroseconds diff = truncate $ diff * 1000000
+{-# INLINE diffToMicroseconds #-}
 
 diffToMilliseconds :: NominalDiffTime -> Int64
-diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer)
+diffToMilliseconds diff = truncate $ diff * 1000
+{-# INLINE diffToMilliseconds #-}
 
 labelMyThread :: MonadIO m => String -> m ()
 labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label)
 
+atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO ()
+atomicModifyIORef'_ r f = atomicModifyIORef' r (\v -> (f v, ()))
+
 encodeJSON :: ToJSON a => a -> Text
 encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
 

src/Simplex/RemoteControl/Client.hs

@@ -23,6 +23,9 @@ module Simplex.RemoteControl.Client
     rcEncryptBody,
     rcDecryptBody,
     xrcpBlockSize,
+    -- for tests only
+    sendRCPacket,
+    receiveRCPacket,
   ) where
 
 import Control.Applicative ((<|>))
@@ -33,6 +36,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
+import Data.Bitraversable (bimapM)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
@@ -43,6 +47,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (isNothing)
 import qualified Data.Text as T
 import Data.Time.Clock.System (getSystemTime)
+import Data.Tuple (swap)
 import Data.Word (Word16)
 import qualified Data.X509 as X509
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
@@ -57,7 +62,7 @@ import Simplex.Messaging.Crypto.SNTRUP761
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Transport (TLS (..), cGet, cPut)
+import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), cGet, cPut)
 import Simplex.Messaging.Transport.Buffer (peekBuffered)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient)
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -214,15 +219,16 @@ prepareHostSession
     hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
     unless (ca == tlsHostFingerprint) $ throwE RCEIdentity
     (kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey
-    let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
+    let KEMHybridSecret hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
     unless (isCompatible v supportedRCPVRange) $ throwE RCEVersion
-    let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey}
+    (sndKey, rcvKey) <- bimapM newTVarIO newTVarIO $ C.sbcInit "" hybridKey
+    let keys = HostSessKeys {chainKeys = TSbChainKeys {sndKey, rcvKey}, idPrivKey, sessPrivKey}
     knownHost' <- updateKnownHost ca dhPubKey
     let ctrlHello = RCCtrlHello {}
     -- TODO send error response if something fails
-    nonce' <- liftIO . atomically $ C.randomCbNonce drg
-    encBody' <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt hybridKey nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
-    let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, nonce = nonce', encBody = encBody'}
+    (sk, nonce') <- atomically $ stateTVar sndKey C.sbcHkdf
+    encBody' <- liftEitherWith (const RCEBlockSize) $ C.sbEncrypt sk nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
+    let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, encBody = encBody'}
     pure (ctrlEncHello, keys, hostHello, pairing {knownHost = Just knownHost'})
     where
       updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing
@@ -305,7 +311,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
 
 catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a
 catchRCError = catchAllErrors $ \e -> case fromException e of
-  Just (TLS.Terminated _ _ (TLS.Error_Protocol (_, _, TLS.UnknownCa))) -> RCEIdentity
+  Just (TLS.Terminated _ _ (TLS.Error_Protocol _ TLS.UnknownCa)) -> RCEIdentity
   _ -> RCEException $ show e
 {-# INLINE catchRCError #-}
 
@@ -349,13 +355,16 @@ prepareCtrlSession
   RCInvitation {skey, dh = dhPubKey}
   sharedKey
   kemPrivKey = \case
-    RCCtrlEncHello {kem = kemCiphertext, nonce, encBody} -> do
+    RCCtrlEncHello {kem = kemCiphertext, encBody} -> do
       kemSharedKey <- liftIO $ sntrup761Dec kemCiphertext kemPrivKey
-      let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
-      helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt hybridKey nonce encBody
+      let KEMHybridSecret hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
+      -- keys are swapped in controller
+      (sndKey, rcvKey) <- swap <$> bimapM newTVarIO newTVarIO (C.sbcInit "" hybridKey)
+      (sk, nonce) <- atomically $ stateTVar rcvKey C.sbcHkdf
+      helloBody <- liftEitherWith (const RCEDecrypt) $ C.sbDecrypt sk nonce encBody
       logDebug "Decrypted ctrl HELLO"
       RCCtrlHello {} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
-      pure CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
+      pure CtrlSessKeys {chainKeys = TSbChainKeys {sndKey, rcvKey}, idPubKey, sessPubKey = skey}
     RCCtrlEncError {nonce, encMessage} -> do
       message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage
       throwE $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message
@@ -426,17 +435,14 @@ cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do
 
 -- * Session encryption
 
-rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString)
-rcEncryptBody drg hybridKey s = do
-  nonce <- atomically $ C.randomCbNonce drg
-  let len = LB.length s
-  ct <- liftEitherWith (const RCEEncrypt) $ LC.kcbEncryptTailTag hybridKey nonce s len (len + 8)
-  pure (nonce, ct)
+rcEncryptBody :: C.SbKeyNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
+rcEncryptBody keyNonce s = do
+  liftEitherWith (const RCEEncrypt) $ LC.sbEncryptTailTagNoPad keyNonce s
 
-rcDecryptBody :: KEMHybridSecret -> C.CbNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
-rcDecryptBody hybridKey nonce ct = do
+rcDecryptBody :: C.SbKeyNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
+rcDecryptBody keyNonce ct = do
   let len = LB.length ct - 16
   when (len < 0) $ throwE RCEDecrypt
-  (ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.kcbDecryptTailTag hybridKey nonce len ct
+  (ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.sbDecryptTailTagNoPad keyNonce len ct
   unless ok $ throwE RCEDecrypt
   pure s

src/Simplex/RemoteControl/Discovery.hs

@@ -71,7 +71,7 @@ preferAddress RCCtrlAddress {address, interface} addrs =
 startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ())
 startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do
   started <- newEmptyTMVarIO
-  bracketOnError (startTCPServer started $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->
+  bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->
     ifM
       (atomically $ readTMVar started)
       (runServer started socket)

src/Simplex/RemoteControl/Types.hs

@@ -20,12 +20,11 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.SNTRUP761
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
-import Simplex.Messaging.Transport (TLS)
+import Simplex.Messaging.Transport (TLS, TSbChainKeys)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
@@ -180,7 +179,7 @@ data RCHostSession = RCHostSession
   }
 
 data HostSessKeys = HostSessKeys
-  { hybridKey :: KEMHybridSecret,
+  { chainKeys :: TSbChainKeys,
     idPrivKey :: C.PrivateKeyEd25519,
     sessPrivKey :: C.PrivateKeyEd25519
   }
@@ -193,7 +192,7 @@ data RCCtrlSession = RCCtrlSession
   }
 
 data CtrlSessKeys = CtrlSessKeys
-  { hybridKey :: KEMHybridSecret,
+  { chainKeys :: TSbChainKeys,
     idPubKey :: C.PublicKeyEd25519,
     sessPubKey :: C.PublicKeyEd25519
   }
@@ -213,19 +212,19 @@ instance Encoding RCHostEncHello where
     pure RCHostEncHello {dhPubKey, nonce, encBody}
 
 data RCCtrlEncHello
-  = RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString}
+  = RCCtrlEncHello {kem :: KEMCiphertext, encBody :: ByteString}
   | RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString}
   deriving (Show)
 
 instance Encoding RCCtrlEncHello where
   smpEncode = \case
-    RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody)
+    RCCtrlEncHello {kem, encBody} -> "HELLO " <> smpEncode (kem, Tail encBody)
     RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage)
   smpP =
     A.takeTill (== ' ') >>= \case
       "HELLO" -> do
-        (kem, nonce, Tail encBody) <- _smpP
-        pure RCCtrlEncHello {kem, nonce, encBody}
+        (kem, Tail encBody) <- _smpP
+        pure RCCtrlEncHello {kem, encBody}
       "ERROR" -> do
         (nonce, Tail encMessage) <- _smpP
         pure RCCtrlEncError {nonce, encMessage}

tests/AgentTests.hs

@@ -24,6 +24,6 @@ agentTests (ATransport t) = do
   describe "Connection request" connectionRequestTests
   describe "Double ratchet tests" doubleRatchetTests
   describe "Functional API" $ functionalAPITests (ATransport t)
-  describe "Notification tests" $ notificationTests (ATransport t)
+  fdescribe "Notification tests" $ notificationTests (ATransport t)
   describe "SQLite store" storeTests
   describe "Migration tests" migrationTests

tests/AgentTests/ConnectionRequestTests.hs

@@ -20,7 +20,7 @@ import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC)
+import Simplex.Messaging.Protocol (EntityId (..), ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC)
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import Simplex.Messaging.Version
 import Test.Hspec
@@ -35,7 +35,7 @@ queueAddr :: SMPQueueAddress
 queueAddr =
   SMPQueueAddress
     { smpServer = srv,
-      senderId = "\223\142z\251",
+      senderId = EntityId "\223\142z\251",
       dhPublicKey = testDhKey,
       sndSecure = False
     }

tests/AgentTests/FunctionalAPITests.hs

@@ -85,7 +85,7 @@ import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
 import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
-import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
+import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (..), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
@@ -283,6 +283,9 @@ functionalAPITests t = do
     testPQMatrix3 t $ runAgentClientContactTestPQ3 True
   it "should support rejecting contact request" $
     withSmpServer t testRejectContactRequest
+  describe "Changing connection user id" $ do
+    it "should change user id for new connections" $ do
+      withSmpServer t testUpdateConnectionUserId
   describe "Establishing connection asynchronously" $ do
     it "should connect with initiating client going offline" $
       withSmpServer t testAsyncInitiatingOffline
@@ -912,6 +915,25 @@ testRejectContactRequest =
     rejectContact alice addrConnId invId
     liftIO $ noMessages bob "nothing delivered to bob"
 
+testUpdateConnectionUserId :: HasCallStack => IO ()
+testUpdateConnectionUserId =
+  withAgentClients2 $ \alice bob -> runRight_ $ do
+    (connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
+    newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
+    _ <- changeConnectionUser alice 1 connId newUserId
+    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+    (aliceId', sqSecured') <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    liftIO $ do
+      aliceId' `shouldBe` aliceId
+      sqSecured' `shouldBe` True
+    ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
+    liftIO $ pqSup' `shouldBe` PQSupportOn
+    allowConnection alice connId confId "alice's connInfo"
+    let pqEnc = CR.pqSupportToEnc PQSupportOn
+    get alice ##> ("", connId, A.CON pqEnc)
+    get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
+    get bob ##> ("", aliceId, A.CON pqEnc)
+
 testAsyncInitiatingOffline :: HasCallStack => IO ()
 testAsyncInitiatingOffline =
   withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do
@@ -1041,13 +1063,12 @@ testAllowConnectionClientRestart t = do
     threadDelay 250000
 
     alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+    runRight_ $ subscribeConnection alice2 bobId
+    threadDelay 500000
 
     withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
       runRight $ do
         ("", "", UP _ _) <- nGet bob
-
-        subscribeConnection alice2 bobId
-
         get alice2 ##> ("", bobId, CON)
         get bob ##> ("", aliceId, INFO "alice's connInfo")
         get bob ##> ("", aliceId, CON)
@@ -2993,7 +3014,7 @@ testDeliveryReceiptsConcurrent t =
 testTwoUsers :: HasCallStack => IO ()
 testTwoUsers = withAgentClients2 $ \a b -> do
   let nc = netCfg initAgentServers
-  sessionMode nc `shouldBe` TSMUser
+  sessionMode nc `shouldBe` TSMSession
   runRight_ $ do
     (aId1, bId1) <- makeConnectionForUsers a 1 b 1
     exchangeGreetings a bId1 b aId1

tests/AgentTests/NotificationTests.hs

@@ -49,6 +49,7 @@ import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.List.NonEmpty as L
 import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple.QQ (sql)
 import NtfClient
@@ -66,6 +67,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..))
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
@@ -139,10 +141,10 @@ notificationTests t = do
     it "should resume subscriptions after SMP server is restarted" $
       withAPNSMockServer $ \apns ->
         withNtfServer t $ testNotificationsSMPRestart t apns
-  describe "Notifications after SMP server restart" $
+  fdescribe "Notifications after SMP server restart" $
     it "should resume batched subscriptions after SMP server is restarted" $
       withAPNSMockServer $ \apns ->
-        withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
+        withNtfServer t $ testNotificationsSMPRestartBatch 150 t apns
   describe "should switch notifications to the new queue" $
     testServerMatrix2 t $ \servers ->
       withAPNSMockServer $ \apns ->
@@ -164,7 +166,7 @@ testNtfMatrix t runTest = do
     it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest
     it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
     it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
-    it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
+    it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
     -- servers can be upgraded in any order
     it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
     it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
@@ -508,6 +510,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
   suspendAgent alice 0
   closeSQLiteStore store
   threadDelay 1000000
+  putStrLn "before opening the database from another agent"
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
   withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
@@ -515,6 +518,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
     pure ()
 
   threadDelay 1000000
+  putStrLn "after closing the database in another agent"
   reopenSQLiteStore store
   foregroundAgent alice
   threadDelay 500000
@@ -870,8 +874,8 @@ messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockReques
 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
+  Right pnMsgs <- liftEither . first INTERNAL $ Right . parseAll pnMessagesP =<< first show (C.cbDecrypt dhSecret nonce message)
+  pure $ L.last pnMsgs
 
 noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
 noNotification apnsQ = do

tests/AgentTests/SQLiteTests.hs

@@ -50,7 +50,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Protocol (SubscriptionMode (..), pattern VersionSMPC)
+import Simplex.Messaging.Protocol (EntityId (..), SubscriptionMode (..), pattern VersionSMPC)
 import qualified Simplex.Messaging.Protocol as SMP
 import System.Random
 import Test.Hspec
@@ -114,6 +114,8 @@ storeTests = do
           testDeleteRcvConn
           testDeleteSndConn
           testDeleteDuplexConn
+        describe "setConnUserId" $ do
+          testSetConnUserIdNewConn
         describe "upgradeRcvConnToDuplex" $ do
           testUpgradeRcvConnToDuplex
         describe "upgradeSndConnToDuplex" $ do
@@ -215,12 +217,12 @@ rcvQueue1 =
     { userId = 1,
       connId = "conn1",
       server = smpServer1,
-      rcvId = "1234",
+      rcvId = EntityId "1234",
       rcvPrivateKey = testPrivateAuthKey,
       rcvDhSecret = testDhSecret,
       e2ePrivKey = testPrivDhKey,
       e2eDhSecret = Nothing,
-      sndId = "2345",
+      sndId = EntityId "2345",
       sndSecure = True,
       status = New,
       dbQueueId = DBNewQueue,
@@ -238,7 +240,7 @@ sndQueue1 =
     { userId = 1,
       connId = "conn1",
       server = smpServer1,
-      sndId = "3456",
+      sndId = EntityId "3456",
       sndSecure = True,
       sndPublicKey = testPublicAuthKey,
       sndPrivateKey = testPrivateAuthKey,
@@ -330,12 +332,27 @@ testGetRcvConn :: SpecWith SQLiteStore
 testGetRcvConn =
   it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do
     let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash
-    let recipientId = "1234"
+    let recipientId = EntityId "1234"
     g <- C.newRandom
     Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getRcvConn db smpServer recipientId
       `shouldReturn` Right (rq, SomeConn SCRcv (RcvConnection cData1 rq))
 
+testSetConnUserIdNewConn :: SpecWith SQLiteStore
+testSetConnUserIdNewConn =
+  it "should set user id for new connection" . withStoreTransaction $ \db -> do
+    g <- C.newRandom
+    Right connId <- createNewConn db g cData1 {connId = ""} SCMInvitation
+    newUserId <- createUserRecord db
+    _ <- setConnUserId db 1 connId newUserId
+    connResult <- getConn db connId
+    case connResult of
+      Right (SomeConn SCNew (NewConnection connData)) -> do
+        let ConnData {userId} = connData
+        userId `shouldBe` newUserId
+      _ -> do
+         expectationFailure "Failed to get connection"
+
 testDeleteRcvConn :: SpecWith SQLiteStore
 testDeleteRcvConn =
   it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do
@@ -383,7 +400,7 @@ testUpgradeRcvConnToDuplex =
             { userId = 1,
               connId = "conn1",
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
-              sndId = "2345",
+              sndId = EntityId "2345",
               sndSecure = True,
               sndPublicKey = testPublicAuthKey,
               sndPrivateKey = testPrivateAuthKey,
@@ -412,12 +429,12 @@ testUpgradeSndConnToDuplex =
             { userId = 1,
               connId = "conn1",
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
-              rcvId = "3456",
+              rcvId = EntityId "3456",
               rcvPrivateKey = testPrivateAuthKey,
               rcvDhSecret = testDhSecret,
               e2ePrivKey = testPrivDhKey,
               e2eDhSecret = Nothing,
-              sndId = "4567",
+              sndId = EntityId "4567",
               sndSecure = True,
               status = New,
               dbQueueId = DBNewQueue,
@@ -539,7 +556,7 @@ mkSndMsgData internalId internalSndId internalHash =
 testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndQueue -> SndMsgData -> Expectation
 testCreateSndMsg_ db expectedPrevHash connId sq sndMsgData@SndMsgData {..} = do
   updateSndIds db connId
-    `shouldReturn` (internalId, internalSndId, expectedPrevHash)
+    `shouldReturn` Right (internalId, internalSndId, expectedPrevHash)
   createSndMsg db connId sndMsgData
     `shouldReturn` ()
   createSndMsgDelivery db connId sq internalId
@@ -644,30 +661,30 @@ testGetPendingServerCommand :: SQLiteStore -> Expectation
 testGetPendingServerCommand st = do
   g <- C.newRandom
   withTransaction st $ \db -> do
-    Right Nothing <- getPendingServerCommand db Nothing
+    Right Nothing <- getPendingServerCommand db "" Nothing
     Right connId <- createNewConn db g cData1 {connId = ""} SCMInvitation
     Right () <- createCommand db "1" connId Nothing command
     corruptCmd db "1" connId
     Right () <- createCommand db "2" connId Nothing command
 
-    Left e <- getPendingServerCommand db Nothing
+    Left e <- getPendingServerCommand db connId Nothing
     show e `shouldContain` "bad AgentCmdType"
     DB.query_ db "SELECT conn_id, corr_id FROM commands WHERE failed = 1" `shouldReturn` [(connId, "1" :: ByteString)]
 
-    Right (Just PendingCommand {corrId}) <- getPendingServerCommand db Nothing
+    Right (Just PendingCommand {corrId}) <- getPendingServerCommand db connId Nothing
     corrId `shouldBe` "2"
 
     Right _ <- updateNewConnRcv db connId rcvQueue1
-    Right Nothing <- getPendingServerCommand db $ Just smpServer1
+    Right Nothing <- getPendingServerCommand db connId $ Just smpServer1
     Right () <- createCommand db "3" connId (Just smpServer1) command
     corruptCmd db "3" connId
     Right () <- createCommand db "4" connId (Just smpServer1) command
 
-    Left e' <- getPendingServerCommand db (Just smpServer1)
+    Left e' <- getPendingServerCommand db connId (Just smpServer1)
     show e' `shouldContain` "bad AgentCmdType"
     DB.query_ db "SELECT conn_id, corr_id FROM commands WHERE failed = 1" `shouldReturn` [(connId, "1" :: ByteString), (connId, "3" :: ByteString)]
 
-    Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db (Just smpServer1)
+    Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db connId (Just smpServer1)
     corrId' `shouldBe` "4"
   where
     command = AClientCommand $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
@@ -698,7 +715,7 @@ rcvFileDescr1 =
     }
   where
     defaultChunkSize = FileSize $ mb 8
-    replicaId = ChunkReplicaId "abc"
+    replicaId = ChunkReplicaId $ EntityId "abc"
     chunkDigest = FileDigest "ghi"
 
 testFileSbKey :: C.SbKey
@@ -724,7 +741,7 @@ testGetNextRcvChunkToDownload st = do
     show e `shouldContain` "ConversionFailed"
     DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
 
-    Right (Just (RcvFileChunk {rcvFileEntityId}, _)) <- getNextRcvChunkToDownload db xftpServer1 86400
+    Right (Just (RcvFileChunk {rcvFileEntityId}, _, Nothing)) <- getNextRcvChunkToDownload db xftpServer1 86400
     rcvFileEntityId `shouldBe` fId2
 
 testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation
@@ -768,9 +785,9 @@ newSndChunkReplica1 :: NewSndChunkReplica
 newSndChunkReplica1 =
   NewSndChunkReplica
     { server = xftpServer1,
-      replicaId = ChunkReplicaId "abc",
+      replicaId = ChunkReplicaId $ EntityId "abc",
       replicaKey = testFileReplicaKey,
-      rcvIdsKeys = [(ChunkReplicaId "abc", testFileReplicaKey)]
+      rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)]
     }
 
 testGetNextSndChunkToUpload :: SQLiteStore -> Expectation
@@ -801,9 +818,9 @@ testGetNextDeletedSndChunkReplica st = do
   withTransaction st $ \db -> do
     Right Nothing <- getNextDeletedSndChunkReplica db xftpServer1 86400
 
-    createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId "abc") testFileReplicaKey) (FileDigest "ghi")
+    createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId $ EntityId "abc") testFileReplicaKey) (FileDigest "ghi")
     DB.execute_ db "UPDATE deleted_snd_chunk_replicas SET delay = 'bad' WHERE deleted_snd_chunk_replica_id = 1"
-    createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId "abc") testFileReplicaKey) (FileDigest "ghi")
+    createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId $ EntityId "abc") testFileReplicaKey) (FileDigest "ghi")
 
     Left e <- getNextDeletedSndChunkReplica db xftpServer1 86400
     show e `shouldContain` "ConversionFailed"

tests/CoreTests/BatchingTests.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -40,6 +41,7 @@ batchingTests = do
       it "should break on large message" testClientBatchWithLargeMessage
     describe "v7 (next)" $ do
       it "should batch with 136 subscriptions per batch" testClientBatchSubscriptionsV7
+      it "should batch with N ENDs per batch" testClientBatchENDs
       it "should break on message that does not fit" testClientBatchWithMessageV7
       it "should break on large message" testClientBatchWithLargeMessageV7
 
@@ -165,6 +167,20 @@ testClientBatchSubscriptionsV7 = do
   (length rs1, length rs2, length rs3) `shouldBe` (28, 136, 136)
   all lenOk [s1, s2, s3] `shouldBe` True
 
+testClientBatchENDs :: IO ()
+testClientBatchENDs = do
+  client <- clientStubV7
+  ends <- replicateM 300 randomENDCmd
+  let ends' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ends
+      batches1 = batchTransmissions False smpBlockSize $ L.fromList ends'
+  all lenOk1 batches1 `shouldBe` True
+  let batches = batchTransmissions True smpBlockSize $ L.fromList ends'
+  length batches `shouldBe` 2
+  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
+  (n1, n2) `shouldBe` (45, 255)
+  (length rs1, length rs2) `shouldBe` (45, 255)
+  all lenOk [s1, s2] `shouldBe` True
+
 testClientBatchWithMessage :: IO ()
 testClientBatchWithMessage = do
   client <- testClientStub
@@ -285,7 +301,7 @@ randomSUB_ a v sessId = do
   (rKey, rpKey) <- atomically $ C.generateAuthKeyPair a g
   thAuth_ <- testTHandleAuth v g rKey
   let thParams = testTHandleParams v sessId
-      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, rId, Cmd SRecipient SUB)
+      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB)
   pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth
 
 randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
@@ -299,7 +315,13 @@ randomSUBCmd_ a c = do
   g <- C.newRandom
   rId <- atomically $ C.randomBytes 24 g
   (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
-  mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB)
+  mkTransmission c (Just rpKey, EntityId rId, Cmd SRecipient SUB)
+
+randomENDCmd :: IO (Transmission BrokerMsg)
+randomENDCmd = do
+  g <- C.newRandom
+  rId <- atomically $ C.randomBytes 24 g
+  pure (CorrId "", EntityId rId, END)
 
 randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
 randomSEND = randomSEND_ C.SEd25519 subModeSMPVersion
@@ -316,7 +338,7 @@ randomSEND_ a v sessId len = do
   thAuth_ <- testTHandleAuth v g sKey
   msg <- atomically $ C.randomBytes len g
   let thParams = testTHandleParams v sessId
-      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
+      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
   pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) nonce tForAuth
 
 testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient
@@ -355,7 +377,7 @@ randomSENDCmd_ a c len = do
   sId <- atomically $ C.randomBytes 24 g
   (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
   msg <- atomically $ C.randomBytes len g
-  mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg)
+  mkTransmission c (Just rpKey, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
 
 lenOk :: ByteString -> Bool
 lenOk s = 0 < B.length s && B.length s <= smpBlockSize - 2

tests/CoreTests/SOCKSSettings.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
+module CoreTests.SOCKSSettings where
+
+import Network.Socket (SockAddr (..), tupleToHostAddress)
+import Simplex.Messaging.Client
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (ErrorType)
+import Simplex.Messaging.Transport.Client
+import Test.Hspec
+
+socksSettingsTests :: Spec
+socksSettingsTests = do
+  describe "hostMode and requiredHostMode settings" testHostMode
+  describe "socksMode setting, independent of hostMode setting" testSocksMode
+  describe "socks proxy address encoding" testSocksProxyEncoding
+
+testPublicHost :: TransportHost
+testPublicHost = "smp.example.com"
+
+testOnionHost :: TransportHost
+testOnionHost = "abcdefghijklmnopqrstuvwxyz0123456789abcdefghijklmnopqrst.onion"
+
+testHostMode :: Spec
+testHostMode = do
+  describe "requiredHostMode = False (default)" $ do
+    it "without socks proxy, should choose onion host only with HMOnion" $ do
+      chooseTransportHost @ErrorType defaultNetworkConfig [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
+      chooseHost HMOnionViaSocks Nothing [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
+      chooseHost HMOnion Nothing [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
+      chooseHost HMPublic Nothing [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
+    it "with socks proxy, should choose onion host with HMOnionViaSocks (default) and HMOnion" $ do
+      chooseTransportHost @ErrorType defaultNetworkConfig {socksProxy = Just defaultSocksProxyWithAuth} [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
+      chooseHost HMOnionViaSocks (Just defaultSocksProxyWithAuth) [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
+      chooseHost HMOnion (Just defaultSocksProxyWithAuth) [testPublicHost, testOnionHost] `shouldBe` Right testOnionHost
+      chooseHost HMPublic (Just defaultSocksProxyWithAuth) [testPublicHost, testOnionHost] `shouldBe` Right testPublicHost
+    it "should choose any available host, if preferred not available" $ do
+      chooseHost HMOnionViaSocks Nothing [testOnionHost] `shouldBe` Right testOnionHost
+      chooseHost HMOnion Nothing [testPublicHost] `shouldBe` Right testPublicHost
+      chooseHost HMPublic Nothing [testOnionHost] `shouldBe` Right testOnionHost
+      chooseHost HMOnionViaSocks (Just defaultSocksProxyWithAuth) [testPublicHost] `shouldBe` Right testPublicHost
+      chooseHost HMOnion (Just defaultSocksProxyWithAuth) [testPublicHost] `shouldBe` Right testPublicHost
+      chooseHost HMPublic (Just defaultSocksProxyWithAuth) [testOnionHost] `shouldBe` Right testOnionHost
+  describe "requiredHostMode = True" $ do
+    it "should fail, if preferred host not available" $ do
+      testOnionHost `incompatible` (HMOnionViaSocks, Nothing)
+      testPublicHost `incompatible` (HMOnion, Nothing)
+      testOnionHost `incompatible` (HMPublic, Nothing)
+      testPublicHost `incompatible` (HMOnionViaSocks, Just defaultSocksProxyWithAuth)
+      testPublicHost `incompatible` (HMOnion, Just defaultSocksProxyWithAuth)
+      testOnionHost `incompatible` (HMPublic, Just defaultSocksProxyWithAuth)
+    it "should choose preferred host, if available" $ do
+      testPublicHost `compatible` (HMOnionViaSocks, Nothing)
+      testOnionHost `compatible` (HMOnion, Nothing)
+      testPublicHost `compatible` (HMPublic, Nothing)
+      testOnionHost `compatible` (HMOnionViaSocks, Just defaultSocksProxyWithAuth)
+      testOnionHost `compatible` (HMOnion, Just defaultSocksProxyWithAuth)
+      testPublicHost `compatible` (HMPublic, Just defaultSocksProxyWithAuth)
+  where
+    chooseHost = chooseHostCfg defaultNetworkConfig
+    host `incompatible` (hostMode, socksProxy) =
+      chooseHostCfg defaultNetworkConfig {requiredHostMode = True} hostMode socksProxy [host] `shouldBe` Left PCEIncompatibleHost
+    host `compatible` (hostMode, socksProxy) = do
+      chooseHostCfg defaultNetworkConfig {requiredHostMode = True} hostMode socksProxy [host] `shouldBe` Right host
+      chooseHostCfg defaultNetworkConfig {requiredHostMode = True} hostMode socksProxy [host, testPublicHost, testOnionHost] `shouldBe` Right host
+    chooseHostCfg cfg hostMode socksProxy =
+      chooseTransportHost @ErrorType cfg {hostMode, socksProxy}
+
+testSocksMode :: Spec
+testSocksMode = do
+  it "should not use SOCKS proxy if not specified" $ do
+    transportSocksCfg defaultNetworkConfig testPublicHost `shouldBe` Nothing
+    transportSocksCfg defaultNetworkConfig testOnionHost `shouldBe` Nothing
+    transportSocks Nothing SMAlways testPublicHost `shouldBe` Nothing
+    transportSocks Nothing SMAlways testOnionHost `shouldBe` Nothing
+    transportSocks Nothing SMOnion testPublicHost `shouldBe` Nothing
+    transportSocks Nothing SMOnion testOnionHost `shouldBe` Nothing
+  it "should always use SOCKS proxy if specified and (socksMode = SMAlways or (socksMode = SMOnion and onion host))" $ do
+    transportSocksCfg defaultNetworkConfig {socksProxy = Just defaultSocksProxyWithAuth} testPublicHost `shouldBe` Just defaultSocksProxy
+    transportSocksCfg defaultNetworkConfig {socksProxy = Just defaultSocksProxyWithAuth} testOnionHost `shouldBe` Just defaultSocksProxy
+    transportSocks (Just defaultSocksProxyWithAuth) SMAlways testPublicHost `shouldBe` Just defaultSocksProxy
+    transportSocks (Just defaultSocksProxyWithAuth) SMAlways testOnionHost `shouldBe` Just defaultSocksProxy
+    transportSocks (Just defaultSocksProxyWithAuth) SMOnion testPublicHost `shouldBe` Nothing
+    transportSocks (Just defaultSocksProxyWithAuth) SMOnion testOnionHost `shouldBe` Just defaultSocksProxy
+  where
+    transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
+    transportSocksCfg cfg host =
+      let TransportClientConfig {socksProxy} = transportClientConfig cfg host
+       in socksProxy
+
+testSocksProxyEncoding :: Spec
+testSocksProxyEncoding = do
+  it "should decode SOCKS proxy with isolate-by-auth mode" $ do
+    let authIsolate proxy = Right $ SocksProxyWithAuth SocksIsolateByAuth proxy
+    strDecode "" `shouldBe` authIsolate defaultSocksProxy
+    strDecode ":9050" `shouldBe` authIsolate defaultSocksProxy
+    strDecode ":8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet 8080 $ tupleToHostAddress defaultSocksHost)
+    strDecode "127.0.0.1" `shouldBe` authIsolate defaultSocksProxy
+    strDecode "1.1.1.1" `shouldBe` authIsolate (SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress (1, 1, 1, 1))
+    strDecode "::1" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)
+    strDecode "[fd12:3456:789a:1::1]" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 9050 0 (0xfd123456, 0x789a0001, 0, 1) 0)
+    strDecode "127.0.0.1:9050" `shouldBe` authIsolate defaultSocksProxy
+    strDecode "127.0.0.1:8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet 8080 $ tupleToHostAddress defaultSocksHost)
+    strDecode "[::1]:9050" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)
+    strDecode "[::1]:8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 8080 0 (0, 0, 0, 1) 0)
+    strDecode "[fd12:3456:789a:1::1]:8080" `shouldBe` authIsolate (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)
+    strEncode (SocksProxyWithAuth SocksIsolateByAuth defaultSocksProxy) `shouldBe` "127.0.0.1:9050"
+    strEncode (SocksProxyWithAuth SocksIsolateByAuth (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)) `shouldBe` "[::1]:9050"
+    strEncode (SocksProxyWithAuth SocksIsolateByAuth (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)) `shouldBe` "[fd12:3456:789a:1::1]:8080"
+  it "should decode SOCKS proxy without credentials" $ do
+    let authNull proxy = Right $ SocksProxyWithAuth SocksAuthNull proxy
+    strDecode "@" `shouldBe` authNull defaultSocksProxy
+    strDecode "@:9050" `shouldBe` authNull defaultSocksProxy
+    strDecode "@127.0.0.1" `shouldBe` authNull defaultSocksProxy
+    strDecode "@1.1.1.1" `shouldBe` authNull (SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress (1, 1, 1, 1))
+    strDecode "@127.0.0.1:9050" `shouldBe` authNull defaultSocksProxy
+    strDecode "@[fd12:3456:789a:1::1]:8080" `shouldBe` authNull (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)
+    strEncode (SocksProxyWithAuth SocksAuthNull defaultSocksProxy) `shouldBe` "@127.0.0.1:9050"
+    strEncode (SocksProxyWithAuth SocksAuthNull (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)) `shouldBe` "@[::1]:9050"
+    strEncode (SocksProxyWithAuth SocksAuthNull (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)) `shouldBe` "@[fd12:3456:789a:1::1]:8080"
+  it "should decode SOCKS proxy with credentials" $ do
+    let auth = SocksAuthUsername {username = "user", password = "pass"}
+        authUser proxy = Right $ SocksProxyWithAuth auth proxy
+    strDecode "user:pass@" `shouldBe` authUser defaultSocksProxy
+    strDecode "user:pass@:9050" `shouldBe` authUser defaultSocksProxy
+    strDecode "user:[email protected]" `shouldBe` authUser defaultSocksProxy
+    strDecode "user:[email protected]:9050" `shouldBe` authUser defaultSocksProxy
+    strDecode "user:pass@fd12:3456:789a:1::1" `shouldBe` authUser (SocksProxy $ SockAddrInet6 9050 0 (0xfd123456, 0x789a0001, 0, 1) 0)
+    strDecode "user:pass@[fd12:3456:789a:1::1]:8080" `shouldBe` authUser (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)
+    strEncode (SocksProxyWithAuth auth defaultSocksProxy) `shouldBe` "user:[email protected]:9050"
+    strEncode (SocksProxyWithAuth auth (SocksProxy $ SockAddrInet6 9050 0 (0, 0, 0, 1) 0)) `shouldBe` "user:pass@[::1]:9050"
+    strEncode (SocksProxyWithAuth auth (SocksProxy $ SockAddrInet6 8080 0 (0xfd123456, 0x789a0001, 0, 1) 0)) `shouldBe` "user:pass@[fd12:3456:789a:1::1]:8080"

tests/CoreTests/TRcvQueuesTests.hs

@@ -3,18 +3,21 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module CoreTests.TRcvQueuesTests where
 
 import AgentTests.EqInstances ()
+import qualified Data.ByteString.Char8 as B
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map as M
 import qualified Data.Set as S
+import Data.String (IsString (..))
 import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId)
 import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..))
 import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (SMPServer, pattern VersionSMPC)
+import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer, pattern NoEntity, pattern VersionSMPC)
 import Test.Hspec
 import UnliftIO
 
@@ -31,6 +34,8 @@ tRcvQueuesTests = do
   describe "queue transfer" $ do
     it "getDelSessQueues-batchAddQueues preserves total length" removeSubsTest
 
+instance IsString EntityId where fromString = EntityId . B.pack
+
 checkDataInvariant :: RQ.Queue q => RQ.TRcvQueues q -> IO Bool
 checkDataInvariant trq = atomically $ do
   conns <- readTVar $ RQ.getConnections trq
@@ -44,11 +49,11 @@ checkDataInvariant trq = atomically $ do
 hasConnTest :: IO ()
 hasConnTest = do
   trq <- RQ.empty
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
   checkDataInvariant trq `shouldReturn` True
   atomically (RQ.hasConn "c1" trq) `shouldReturn` True
   atomically (RQ.hasConn "c2" trq) `shouldReturn` True
@@ -58,7 +63,7 @@ hasConnTest = do
 hasConnTestBatch :: IO ()
 hasConnTestBatch = do
   trq <- RQ.empty
-  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"]
+  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"]
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
   atomically (RQ.hasConn "c1" trq) `shouldReturn` True
@@ -69,7 +74,7 @@ hasConnTestBatch = do
 batchIdempotentTest :: IO ()
 batchIdempotentTest = do
   trq <- RQ.empty
-  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"]
+  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"]
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
   qs' <- readTVarIO $ RQ.getRcvQueues trq
@@ -83,9 +88,9 @@ deleteConnTest :: IO ()
 deleteConnTest = do
   trq <- RQ.empty
   atomically $ do
-    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
-    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
-    RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
+    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
+    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
+    RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
   checkDataInvariant trq `shouldReturn` True
   atomically $ RQ.deleteConn "c1" trq
   checkDataInvariant trq `shouldReturn` True
@@ -96,16 +101,16 @@ deleteConnTest = do
 getSessQueuesTest :: IO ()
 getSessQueuesTest = do
   trq <- RQ.empty
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4") trq
+  atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4" "r4") trq
   checkDataInvariant trq `shouldReturn` True
   let tSess1 = (0, "smp://1234-w==@alpha", Just "c1")
-  RQ.getSessQueues tSess1 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1"]
+  RQ.getSessQueues tSess1 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"]
   atomically (RQ.hasSessQueues tSess1 trq) `shouldReturn` True
   let tSess2 = (1, "smp://1234-w==@alpha", Just "c1")
   RQ.getSessQueues tSess2 trq `shouldReturn` []
@@ -114,17 +119,17 @@ getSessQueuesTest = do
   RQ.getSessQueues tSess3 trq `shouldReturn` []
   atomically (RQ.hasSessQueues tSess3 trq) `shouldReturn` False
   let tSess4 = (0, "smp://1234-w==@alpha", Nothing)
-  RQ.getSessQueues tSess4 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"]
+  RQ.getSessQueues tSess4 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"]
   atomically (RQ.hasSessQueues tSess4 trq) `shouldReturn`True
 
 getDelSessQueuesTest :: IO ()
 getDelSessQueuesTest = do
   trq <- RQ.empty
   let qs =
-        [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1"),
-          ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2"),
-          ("1", dummyRQ 0 "smp://1234-w==@beta" "c3"),
-          ("1", dummyRQ 1 "smp://1234-w==@beta" "c4")
+        [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"),
+          ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2"),
+          ("1", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"),
+          ("1", dummyRQ 1 "smp://1234-w==@beta" "c4" "r4")
         ]
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
@@ -137,7 +142,7 @@ getDelSessQueuesTest = do
   -- connections intact
   atomically (RQ.hasConn "c1" trq) `shouldReturn` True
   atomically (RQ.hasConn "c2" trq) `shouldReturn` True
-  atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"], ["c1", "c2"])
+  atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"], ["c1", "c2"])
   checkDataInvariant trq `shouldReturn` True
   -- connections gone
   atomically (RQ.hasConn "c1" trq) `shouldReturn` False
@@ -150,10 +155,10 @@ removeSubsTest :: IO ()
 removeSubsTest = do
   aq <- RQ.empty
   let qs =
-        [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1"),
-          ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2"),
-          ("1", dummyRQ 0 "smp://1234-w==@beta" "c3"),
-          ("1", dummyRQ 1 "smp://1234-w==@beta" "c4")
+        [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"),
+          ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2"),
+          ("1", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"),
+          ("1", dummyRQ 1 "smp://1234-w==@beta" "c4" "r4")
         ]
   atomically $ RQ.batchAddQueues aq qs
 
@@ -180,18 +185,18 @@ totalSize a b = do
   csizeB <- M.size <$> readTVar (RQ.getConnections b)
   pure (qsizeA + qsizeB, csizeA + csizeB)
 
-dummyRQ :: UserId -> SMPServer -> ConnId -> RcvQueue
-dummyRQ userId server connId =
+dummyRQ :: UserId -> SMPServer -> ConnId -> RecipientId -> RcvQueue
+dummyRQ userId server connId rcvId =
   RcvQueue
     { userId,
       connId,
       server,
-      rcvId = "",
+      rcvId,
       rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
       rcvDhSecret = "01234567890123456789012345678901",
       e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
       e2eDhSecret = Nothing,
-      sndId = "",
+      sndId = NoEntity,
       sndSecure = True,
       status = New,
       dbQueueId = DBQueueId 0,

tests/FileDescriptionTests.hs

@@ -13,6 +13,7 @@ import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Protocol (EntityId (..))
 import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import System.Directory (removeFile)
 import Test.Hspec
@@ -91,7 +92,7 @@ fileDesc =
     }
   where
     defaultChunkSize = FileSize $ mb 8
-    replicaId = ChunkReplicaId "abc"
+    replicaId = ChunkReplicaId $ EntityId "abc"
     replicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
     chunkDigest = FileDigest "ghi"
 

tests/NtfClient.hs

@@ -158,7 +158,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
       [Right ()] <- tPut h [Right (sig, t')]
       pure ()
     tGet' h = do
-      [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
+      [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
 ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation

tests/NtfServerTests.hs

@@ -17,6 +17,7 @@ import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.List.NonEmpty as L
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPClient as SMP
@@ -35,7 +36,6 @@ import ServerTests
 import qualified Simplex.Messaging.Agent.Protocol as AP
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS
@@ -72,13 +72,13 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
 
 deriving instance Eq NtfResponse
 
-sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
 sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do
   let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (sgn, tToSend)
   tGet1 h
 
-signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
 signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (authorize tForAuth, tToSend)
@@ -110,7 +110,7 @@ testNotificationSubscription (ATransport t) =
           -- create queue
           (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub
           -- register and verify token
-          RespNtf "1" "" (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", "", TNEW $ NewNtfTkn tkn tknPub dhPub)
+          RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
           APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse = send} <-
             atomically $ readTBQueue apnsQ
           send APNSRespOk
@@ -126,7 +126,7 @@ testNotificationSubscription (ATransport t) =
           let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
               q = SMPQueueNtf srv nId
               rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
-          RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", "", SNEW $ NewNtfSub tId q nKey)
+          RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey)
           -- send message
           threadDelay 50000
           Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello")
@@ -136,8 +136,8 @@ testNotificationSubscription (ATransport t) =
               Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
               Right message = ntfData' .-> "message"
               Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message
-              Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} =
-                parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
+              Right pnMsgs1 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
+              APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} = L.last pnMsgs1
               Right nMsgMeta = C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta
               Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta
           smpServer `shouldBe` srv
@@ -169,8 +169,8 @@ testNotificationSubscription (ATransport t) =
               Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce"
               Right message3 = ntfData3 .-> "message"
               Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3
-              Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} =
-                parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
+              Right pnMsgs2 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
+              APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2
           smpServer3 `shouldBe` srv
           notifierId3 `shouldBe` nId
           send3 APNSRespOk

tests/RemoteControl.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -8,9 +9,11 @@ import AgentTests.FunctionalAPITests (runRight)
 import Control.Logger.Simple
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
+import Data.ByteString.Lazy.Char8 as LB
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Transport (TSbChainKeys (..))
 import qualified Simplex.RemoteControl.Client as HC (RCHostClient (action))
 import qualified Simplex.RemoteControl.Client as RC
 import Simplex.RemoteControl.Discovery (mkLastLocalHost, preferAddress)
@@ -74,7 +77,16 @@ testNewPairing = do
     logNote "c 3"
     Right (sessId, _tls, r') <- atomically $ takeTMVar r
     logNote "c 4"
-    Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r'
+    Right (rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r'
+    let RCHostSession {tls, sessionKeys = HostSessKeys {chainKeys}} = rcHostSession
+        TSbChainKeys {rcvKey, sndKey} = chainKeys
+    sndKeyNonce <- atomically $ stateTVar sndKey C.sbcHkdf
+    encCmd <- RC.rcEncryptBody sndKeyNonce "command message"
+    RC.sendRCPacket tls $ LB.toStrict encCmd
+    encResp <- RC.receiveRCPacket tls
+    rcvKeyNonce <- atomically $ stateTVar rcvKey C.sbcHkdf
+    resp <- RC.rcDecryptBody rcvKeyNonce $ LB.fromStrict encResp
+    liftIO $ resp `shouldBe` "response message"
     logNote "c 5"
     threadDelay 250000
     logNote "ctrl: ciao"
@@ -93,7 +105,16 @@ testNewPairing = do
     logNote "h 3"
     liftIO $ RC.confirmCtrlSession rcCtrlClient True
     logNote "h 4"
-    Right (_rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r'
+    Right (rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r'
+    let RCCtrlSession {tls, sessionKeys = CtrlSessKeys {chainKeys}} = rcCtrlSession
+        TSbChainKeys {rcvKey, sndKey} = chainKeys
+    encCmd <- RC.receiveRCPacket tls
+    rcvKeyNonce <- atomically $ stateTVar rcvKey C.sbcHkdf
+    cmd <- RC.rcDecryptBody rcvKeyNonce $ LB.fromStrict encCmd
+    liftIO $ cmd `shouldBe` "command message"
+    sndKeyNonce <- atomically $ stateTVar sndKey C.sbcHkdf
+    encResp <- RC.rcEncryptBody sndKeyNonce "response message"
+    RC.sendRCPacket tls $ LB.toStrict encResp
     logNote "h 5"
     threadDelay 250000
     logNote "ctrl: adios"

tests/SMPClient.hs

@@ -115,6 +115,7 @@ cfg =
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/smp-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
+      pendingENDInterval = 500000,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
@@ -218,7 +219,7 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
       [Right ()] <- tPut h [Right (sig, t')]
       pure ()
     tGet' h = do
-      [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
+      [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
 smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation

tests/SMPProxyTests.hs

@@ -22,6 +22,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT)
 import Data.ByteString.Char8 (ByteString)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
+import Data.Time.Clock (getCurrentTime)
 import SMPAgentClient
 import SMPClient
 import ServerTests (decryptMsgV3, sendRecv)
@@ -34,7 +35,7 @@ import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
-import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags)
+import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, maxMessageLength, noMsgFlags)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Transport
@@ -150,12 +151,13 @@ deliverMessagesViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> S
 deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
   g <- C.newRandom
   -- set up proxy
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
+  ts <- getCurrentTime
+  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ())
   pc <- either (fail . show) pure pc'
   THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
   -- set up relay
   msgQ <- newTBQueueIO 1024
-  rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ())
+  rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) ts (\_ -> pure ())
   rc <- either (fail . show) pure rc'
   -- prepare receiving queue
   (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
@@ -192,7 +194,8 @@ proxyConnectDeadRelay :: Int -> Int -> SMPServer -> IO ()
 proxyConnectDeadRelay n d proxyServ = do
   g <- C.newRandom
   -- set up proxy
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
+  ts <- getCurrentTime
+  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ())
   pc <- either (fail . show) pure pc'
   THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
   -- get proxy session
@@ -408,14 +411,14 @@ testNoProxy :: IO ()
 testNoProxy = do
   withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do
     testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do
-      (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer Nothing)
+      (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing)
       reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
 
 testProxyAuth :: IO ()
 testProxyAuth = do
   withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
     testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do
-      (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer2 $ Just "wrong")
+      (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong")
       reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
   where
     proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"}

tests/ServerTests.hs

@@ -25,7 +25,8 @@ import Data.Bifunctor (first)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import qualified Data.Set as S
+import Data.Hashable (hash)
+import qualified Data.IntSet as IS
 import Data.Type.Equality
 import GHC.Stack (withFrozenCallStack)
 import SMPClient
@@ -78,13 +79,13 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure)
 pattern Msg :: MsgId -> MsgBody -> BrokerMsg
 pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
 
-sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
+sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, EntityId, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
 sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do
   let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (sgn, tToSend)
   tGet1 h
 
-signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
+signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
 signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
   Right () <- tPut1 h (authorize tForAuth, tToSend)
@@ -134,9 +135,9 @@ testCreateSecure (ATransport t) =
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
-      (rId1, "") #== "creates queue"
+      (rId1, NoEntity) #== "creates queue"
 
       Resp "bcda" sId1 ok1 <- sendRecv s ("", "bcda", sId, _SEND "hello")
       (ok1, OK) #== "accepts unsigned SEND"
@@ -199,9 +200,9 @@ testCreateDelete (ATransport t) =
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
-      (rId1, "") #== "creates queue"
+      (rId1, NoEntity) #== "creates queue"
 
       (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)
@@ -271,7 +272,7 @@ stressTest (ATransport t) =
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
       rIds <- forM ([1 .. 50] :: [Int]) . const $ do
-        Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False)
+        Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
         pure rId
       let subscribeQueues h = forM_ rIds $ \rId -> do
             Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
@@ -289,7 +290,7 @@ testAllowNewQueues t =
         g <- C.newRandom
         (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
         (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-        Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
+        Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
         pure ()
 
 testDuplex :: ATransport -> Spec
@@ -299,7 +300,7 @@ testDuplex (ATransport t) =
       g <- C.newRandom
       (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False)
+      Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", NoEntity, NEW arPub aDhPub Nothing SMSubscribe False)
       let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
       -- aSnd ID is passed to Bob out-of-band
 
@@ -315,15 +316,15 @@ testDuplex (ATransport t) =
 
       (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False)
+      Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", NoEntity, NEW brPub bDhPub Nothing SMSubscribe False)
       let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
-      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
+      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode (unEntityId bSnd))
       -- "reply_id ..." is ad-hoc, not a part of SMP protocol
 
       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"
+      (bId, encode (unEntityId bSnd)) #== "reply queue ID received from Bob"
 
       (asPub, asKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
@@ -354,7 +355,7 @@ testSwitchSub (ATransport t) =
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
       (ok1, OK) #== "sent test message 1"
@@ -384,6 +385,10 @@ testSwitchSub (ATransport t) =
       Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3)
       (ok3, OK) #== "accepts ACK from the 2nd TCP connection"
 
+      Resp "cdab" _ OK <- signSendRecv rh1 rKey ("cdab", rId, DEL)
+      Resp "" rId' DELD <- tGet1 rh2
+      (rId', rId) #== "connection deleted event delivered to subscribed client"
+
       1000 `timeout` tGet @SMPVersion @ErrorType @BrokerMsg rh1 >>= \case
         Nothing -> return ()
         Just _ -> error "nothing else is delivered to the 1st TCP connection"
@@ -491,12 +496,12 @@ testWithStoreLog at@(ATransport t) =
     (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    recipientId1 <- newTVarIO ""
+    recipientId1 <- newTVarIO NoEntity
     recipientKey1 <- newTVarIO Nothing
     dhShared1 <- newTVarIO Nothing
-    senderId1 <- newTVarIO ""
-    senderId2 <- newTVarIO ""
-    notifierId <- newTVarIO ""
+    senderId1 <- newTVarIO NoEntity
+    senderId2 <- newTVarIO NoEntity
+    notifierId <- newTVarIO NoEntity
 
     withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
@@ -580,10 +585,10 @@ testRestoreMessages at@(ATransport t) =
 
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    recipientId <- newTVarIO ""
+    recipientId <- newTVarIO NoEntity
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
-    senderId <- newTVarIO ""
+    senderId <- newTVarIO NoEntity
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       runClient t $ \h1 -> do
@@ -610,7 +615,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 2
     logSize testStoreMsgsFile `shouldReturn` 5
-    logSize testServerStatsBackupFile `shouldReturn` 71
+    logSize testServerStatsBackupFile `shouldReturn` 72
     Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats1 [rId] 5 1
 
@@ -628,7 +633,7 @@ testRestoreMessages at@(ATransport t) =
     logSize testStoreLogFile `shouldReturn` 1
     -- the last message is not removed because it was not ACK'd
     logSize testStoreMsgsFile `shouldReturn` 3
-    logSize testServerStatsBackupFile `shouldReturn` 71
+    logSize testServerStatsBackupFile `shouldReturn` 72
     Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats2 [rId] 5 3
 
@@ -647,7 +652,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 1
     logSize testStoreMsgsFile `shouldReturn` 0
-    logSize testServerStatsBackupFile `shouldReturn` 71
+    logSize testServerStatsBackupFile `shouldReturn` 72
     Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats3 [rId] 5 5
 
@@ -675,19 +680,19 @@ checkStats s qs sent received = do
   _msgSentNtf s `shouldBe` 0
   _msgRecvNtf s `shouldBe` 0
   let PeriodStatsData {_day, _week, _month} = _activeQueues s
-  S.toList _day `shouldBe` qs
-  S.toList _week `shouldBe` qs
-  S.toList _month `shouldBe` qs
+  IS.toList _day `shouldBe` map (hash . unEntityId) qs
+  IS.toList _week `shouldBe` map (hash . unEntityId) qs
+  IS.toList _month `shouldBe` map (hash . unEntityId) qs
 
 testRestoreExpireMessages :: ATransport -> Spec
 testRestoreExpireMessages at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    recipientId <- newTVarIO ""
+    recipientId <- newTVarIO NoEntity
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
-    senderId <- newTVarIO ""
+    senderId <- newTVarIO NoEntity
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       runClient t $ \h1 -> do
@@ -742,7 +747,7 @@ createAndSecureQueue h sPub = do
   g <- C.newRandom
   (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
   (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-  Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
+  Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
   let dhShared = C.dh' srvDh dhPriv
   Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
   (rId', rId) #== "same queue ID"
@@ -771,13 +776,13 @@ testTiming (ATransport t) =
         (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
       ]
     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
-    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5%
+    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 -- normally the difference between "no queue" and "wrong key" is less than 5%
     testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
     testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do
       g <- C.newRandom
       (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
       (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
-      Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
 
@@ -793,12 +798,12 @@ testTiming (ATransport t) =
 
       runTimingTest sh badKey sId $ _SEND "hello"
       where
-        runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> ByteString -> Command p -> IO ()
+        runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> EntityId -> Command p -> IO ()
         runTimingTest h badKey qId cmd = do
           threadDelay 100000
           _ <- timeRepeat n $ do
             -- "warm up" the server
-            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
+            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd)
             return ()
           threadDelay 100000
           timeWrongKey <- timeRepeat n $ do
@@ -806,7 +811,7 @@ testTiming (ATransport t) =
             return ()
           threadDelay 100000
           timeNoQueue <- timeRepeat n $ do
-            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
+            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd)
             return ()
           let ok = similarTime timeNoQueue timeWrongKey
           unless ok . putStrLn . unwords $
@@ -838,7 +843,8 @@ testMessageNotifications (ATransport t) =
       Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
       Resp "" _ (NMSG _ _) <- tGet1 nh1
       Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
-      Resp "" _ END <- tGet1 nh1
+      Resp "" nId2 END <- tGet1 nh1
+      nId2 `shouldBe` nId
       Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
       Resp "" _ (Msg mId2 msg2) <- tGet1 rh
       Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
@@ -848,6 +854,8 @@ testMessageNotifications (ATransport t) =
         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 "" nId3 DELD <- tGet1 nh2
+      nId3 `shouldBe` nId
       Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
       Resp "" _ (Msg mId3 msg3) <- tGet1 rh
       (dec mId3 msg3, Right "hello there") #== "delivered from queue again"

tests/Test.hs

@@ -12,6 +12,7 @@ import CoreTests.CryptoFileTests
 import CoreTests.CryptoTests
 import CoreTests.EncodingTests
 import CoreTests.RetryIntervalTests
+import CoreTests.SOCKSSettings
 import CoreTests.TRcvQueuesTests
 import CoreTests.UtilTests
 import CoreTests.VersionRangeTests
@@ -52,6 +53,7 @@ main = do
           describe "Encryption tests" cryptoTests
           describe "Encrypted files tests" cryptoFileTests
           describe "Retry interval tests" retryIntervalTests
+          describe "SOCKS settings tests" socksSettingsTests
           describe "TRcvQueues tests" tRcvQueuesTests
           describe "Util tests" utilTests
         describe "SMP server via TLS" $ serverTests (transport @TLS)

tests/XFTPAgent.hs

@@ -429,7 +429,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
       ("", sfId', SFPROG _ _) <- sfGet sndr'
       liftIO $ sfId' `shouldBe` sfId
 
-  threadDelay 100000
+  threadDelay 200000
 
   withXFTPServerStoreLogOn $ \_ -> do
     -- send file - should continue uploading with server up
@@ -443,7 +443,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
       pure rfd1
 
     -- prefix path should be removed after sending file
-    threadDelay 100000
+    threadDelay 200000
     doesDirectoryExist prefixPath `shouldReturn` False
     doesFileExist encPath `shouldReturn` False
 

tests/XFTPClient.hs

@@ -8,6 +8,7 @@ module XFTPClient where
 
 import Control.Concurrent (ThreadId, threadDelay)
 import Data.String (fromString)
+import Data.Time.Clock (getCurrentTime)
 import Network.Socket (ServiceName)
 import SMPClient (serverBracket)
 import Simplex.FileTransfer.Client
@@ -135,7 +136,8 @@ testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
 testXFTPClient = testXFTPClientWith testXFTPClientConfig
 
 testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
-testXFTPClientWith cfg client =
-  getXFTPClient (1, testXFTPServer, Nothing) cfg (\_ -> pure ()) >>= \case
+testXFTPClientWith cfg client = do
+  ts <- getCurrentTime
+  getXFTPClient (1, testXFTPServer, Nothing) cfg ts (\_ -> pure ()) >>= \case
     Right c -> client c
     Left e -> error $ show e

tests/XFTPServerTests.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module XFTPServerTests where
@@ -17,16 +18,17 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.List (isInfixOf)
+import Data.Time.Clock (getCurrentTime)
 import ServerTests (logSize)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description (kb)
-import Simplex.FileTransfer.Protocol (FileInfo (..))
+import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
 import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPRcvChunkSpec (..))
 import Simplex.Messaging.Client (ProtocolClientError (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
-import Simplex.Messaging.Protocol (BasicAuth, SenderId)
+import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
@@ -74,8 +76,8 @@ createTestChunk fp = do
   B.writeFile fp bytes
   pure bytes
 
-readChunk :: SenderId -> IO ByteString
-readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))
+readChunk :: XFTPFileId -> IO ByteString
+readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
 
 testFileChunkDelivery :: Expectation
 testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
@@ -219,7 +221,8 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
 testInactiveClientExpiration :: Expectation
 testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
   disconnected <- newEmptyTMVarIO
-  c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
+  ts <- liftIO getCurrentTime
+  c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig ts (\_ -> atomically $ putTMVar disconnected ())
   pingXFTP c
   liftIO $ do
     threadDelay 100000
@@ -267,9 +270,9 @@ testFileLog = do
   (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
-  sIdVar <- newTVarIO ""
-  rIdVar1 <- newTVarIO ""
-  rIdVar2 <- newTVarIO ""
+  sIdVar <- newTVarIO NoEntity
+  rIdVar1 <- newTVarIO NoEntity
+  rIdVar2 <- newTVarIO NoEntity
 
   threadDelay 100000