6.0.3.0

* put DRG state to IORef, split STM transaction of sending notification (#1288)

* put DRG state to IORef, split STM transaction of sending notification

* remove comment

* remove comment

* add comment

* revert version

* newtype for server entity IDs, fix TRcvQueues

* Revert "put DRG state to IORef, split STM transaction of sending notification (#1288)"

This reverts commit 517933d189.

* logServer

CHANGELOG.md

@@ -1,3 +1,24 @@
+# 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:
@@ -5,7 +26,6 @@ SMP agent:
 - do not start delivery workers when there are no messages to deliver.
 - enable notifications for all connections.
 - combine database transactions when subscribing.
-- store query errors, reduce slow query threshold to 1ms.
 
 SMP server:
 - safe compacting of store log.

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

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.1.0
+version: 6.0.3.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,

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.1.0
+version:        6.0.3
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and

src/Simplex/FileTransfer/Agent.hs

@@ -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, (</>))
@@ -346,7 +346,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

@@ -50,6 +50,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)
@@ -222,7 +223,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 +279,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/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 #-}
 
@@ -37,6 +38,7 @@ 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,7 +54,7 @@ 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.Stats
@@ -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
               ","
@@ -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)
@@ -405,8 +407,8 @@ 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
@@ -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,11 @@ 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)
 
 expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
 expireServerFiles itemDelay expCfg = do
@@ -554,24 +555,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 +592,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,25 @@ 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,
+  { fromTime :: IORef UTCTime,
+    filesCreated :: IORef Int,
+    fileRecipients :: IORef Int,
+    filesUploaded :: IORef Int,
+    filesExpired :: IORef Int,
+    filesDeleted :: IORef Int,
     filesDownloaded :: PeriodStats SenderId,
-    fileDownloads :: TVar Int,
-    fileDownloadAcks :: TVar Int,
-    filesCount :: TVar Int,
-    filesSize :: TVar Int64
+    fileDownloads :: IORef Int,
+    fileDownloadAcks :: IORef Int,
+    filesCount :: IORef Int,
+    filesSize :: IORef Int64
   }
 
 data FileServerStatsData = FileServerStatsData
@@ -45,47 +45,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/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

@@ -128,11 +128,10 @@ 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 ((.:), (.:.), (.::), (.::.))
-import Data.Containers.ListUtils (nubOrd)
 import Data.Either (isRight, rights)
 import Data.Foldable (foldl', toList)
 import Data.Functor (($>))
@@ -178,7 +177,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 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
@@ -892,7 +891,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
 
@@ -1134,37 +1133,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 connIds = do
-  srvs <- nubOrd . concat . rights <$> withStoreBatch' c (\db -> fmap (getPendingCommandServers db) connIds)
-  mapM_ (resumeSrvCmds c) srvs
+  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])
@@ -1190,16 +1191,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
@@ -1272,15 +1284,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 ()
@@ -2193,7 +2208,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
@@ -2330,7 +2345,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
@@ -2340,7 +2355,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
@@ -2363,7 +2378,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
@@ -2485,7 +2500,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
@@ -2554,7 +2569,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"
               _ ->
@@ -2578,7 +2593,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 ())
@@ -2587,7 +2602,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
@@ -2627,7 +2642,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
@@ -2648,7 +2663,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
@@ -2669,7 +2684,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
@@ -2693,7 +2708,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.

src/Simplex/Messaging/Agent/Client.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
@@ -82,6 +83,7 @@ module Simplex.Messaging.Agent.Client
     deleteQueues,
     logServer,
     logSecret,
+    logSecret',
     removeSubscription,
     hasActiveSubscription,
     hasPendingSubscription,
@@ -228,7 +230,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumT
 import Simplex.Messaging.Protocol
   ( AProtocolType (..),
     BrokerMsg,
-    EntityId,
+    EntityId (..),
     ErrorType,
     MsgFlags (..),
     MsgId,
@@ -241,7 +243,6 @@ import Simplex.Messaging.Protocol
     ProtocolServer (..),
     ProtocolType (..),
     ProtocolTypeI (..),
-    QueueId,
     QueueIdsKeys (..),
     RcvMessage (..),
     RcvNtfPublicDhKey,
@@ -255,6 +256,7 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
     XFTPServer,
     XFTPServerWithAuth,
+    pattern NoEntity,
     sameSrvAddr',
   )
 import qualified Simplex.Messaging.Protocol as SMP
@@ -313,7 +315,7 @@ data AgentClient = AgentClient
     removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
     workerSeq :: TVar Int,
     smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
-    asyncCmdWorkers :: TMap (Maybe SMPServer) Worker,
+    asyncCmdWorkers :: TMap (ConnId, Maybe SMPServer) Worker,
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -996,7 +998,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
@@ -1013,32 +1015,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
@@ -1052,14 +1054,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
@@ -1078,7 +1081,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
@@ -1105,7 +1108,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))
@@ -1125,7 +1128,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
@@ -1138,18 +1141,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_
@@ -1291,12 +1294,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
@@ -1318,12 +1321,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,
@@ -1457,7 +1460,7 @@ sendTSessionBatches statCmd toRQ action c qs =
       tryAgentError' (getSMPServerClient c tSess) >>= \case
         Left e -> pure $ L.map ((,Left e) . toRQ) 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
@@ -1511,32 +1514,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
@@ -1572,8 +1582,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
@@ -1603,7 +1613,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNt
 
 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
 
@@ -1637,10 +1647,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,
@@ -1659,7 +1669,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 =
@@ -1707,10 +1717,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 ()
@@ -1734,7 +1744,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

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,
@@ -287,10 +287,12 @@ e2eEncAgentMsgLength v = \case
   _ -> 15856
 
 -- | 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

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 #-}
@@ -137,6 +140,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     createCommand,
     getPendingCommandServers,
     getPendingServerCommand,
+    updateCommandServer,
     deleteCommand,
     -- Notification device token persistence
     createNtfToken,
@@ -1323,38 +1327,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 = ?
@@ -1362,9 +1367,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)
@@ -1799,6 +1817,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

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

@@ -441,7 +441,8 @@ 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.
@@ -544,7 +545,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
@@ -670,7 +671,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
 
@@ -829,7 +830,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 +932,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 +968,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
@@ -1015,7 +1016,7 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz
       | 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

@@ -372,14 +372,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/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

@@ -53,14 +53,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

src/Simplex/Messaging/Notifications/Client.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Messaging.Notifications.Client where
 
@@ -11,7 +12,7 @@ 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 +23,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,7 +47,7 @@ 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
 

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
 

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,14 @@ 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}))
               incNtfStat ntfReceived
-            Right SMP.END -> updateSubStatus smpQueue NSEnd
+            Right SMP.END ->
+              whenM (atomically $ activeClientSession' ca sessionId srv) $
+                updateSubStatus smpQueue NSEnd
             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 +302,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 +449,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 +540,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 +565,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 +578,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 +605,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 #-}
@@ -132,7 +133,8 @@ 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,
+                                smpPingInterval = 60_000_000 -- 1 minutes
                               }
                         },
                     persistErrorInterval = 0 -- seconds

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

@@ -7,22 +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,
+  { 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 NtfTokenId,
     activeSubs :: PeriodStats NotifierId
   }
@@ -42,42 +42,43 @@ data NtfServerStatsData = NtfServerStatsData
 
 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/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
@@ -1097,10 +1106,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
@@ -1323,7 +1335,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
@@ -1448,7 +1460,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 +1733,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.hs

@@ -44,7 +44,6 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Control.Monad.Trans.Except
-import Crypto.Random
 import Control.Monad.STM (retry)
 import Data.Bifunctor (first)
 import Data.ByteString.Base64 (encode)
@@ -54,11 +53,12 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
+import Data.IORef
 import Data.Int (Int64)
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.List (intercalate, mapAccumR)
-import Data.List.NonEmpty (NonEmpty (..))
+import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
@@ -69,6 +69,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Type.Equality
+import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
 import GHC.TypeLits (KnownNat)
 import Network.Socket (ServiceName, Socket, socketToHandle)
@@ -136,8 +137,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
   expired <- restoreServerMessages
   restoreServerStats expired
   raceAny_
-    ( serverThread s "server subscribedQ" subscribedQ subscribers subscriptions cancelSub
-        : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ())
+    ( serverThread s "server subscribedQ" subscribedQ subscribers pendingENDs subscriptions cancelSub
+        : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers pendingNtfENDs ntfSubscriptions (\_ -> pure ())
+        : sendPendingENDsThread s
         : receiveFromProxyAgent pa
         : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
     )
@@ -164,20 +166,20 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       String ->
       (Server -> TQueue (QueueId, Client, Subscribed)) ->
       (Server -> TMap QueueId Client) ->
+      (Server -> IORef (IM.IntMap (NonEmpty RecipientId))) ->
       (Client -> TMap QueueId s) ->
       (s -> IO ()) ->
       M ()
-    serverThread s label subQ subs clientSubs unsub = do
+    serverThread s label subQ subs ends clientSubs unsub = do
       labelMyThread label
       cls <- asks clients
-      forever $
-        atomically (updateSubscribers cls)
+      liftIO . forever $
+        (atomically (readTQueue $ subQ s) >>= atomically . updateSubscribers cls)
           $>>= endPreviousSubscriptions
-          >>= liftIO . mapM_ unsub
+          >>= mapM_ unsub
       where
-        updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> STM (Maybe (QueueId, Client))
-        updateSubscribers cls = do
-          (qId, clnt, subscribed) <- readTQueue $ subQ s
+        updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> (QueueId, Client, Bool) -> STM (Maybe (QueueId, Client))
+        updateSubscribers cls (qId, clnt, subscribed) = do
           current <- IM.member (clientId clnt) <$> readTVar cls
           let updateSub
                 | not subscribed = TM.lookupDelete
@@ -189,12 +191,33 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                     yes <- readTVar $ connected c'
                     pure $ if yes then Just (qId, c') else Nothing
           updateSub qId (subs s) $>>= clientToBeNotified
-        endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
+        endPreviousSubscriptions :: (QueueId, Client) -> IO (Maybe s)
         endPreviousSubscriptions (qId, c) = do
-          forkClient c (label <> ".endPreviousSubscriptions") $
-            atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)]
+          atomicModifyIORef'_ (ends s) $ IM.alter (Just . maybe [qId] (qId <|)) (clientId c)
           atomically $ TM.lookupDelete qId (clientSubs c)
 
+    sendPendingENDsThread :: Server -> M ()
+    sendPendingENDsThread s = do
+      endInt <- asks $ pendingENDInterval . config
+      cls <- asks clients
+      forever $ do
+        threadDelay endInt
+        sendPending cls $ pendingENDs s
+        sendPending cls $ pendingNtfENDs s
+      where
+        sendPending cls ref = do
+          ends <- liftIO $ atomicSwapIORef ref IM.empty
+          unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qIds) ->
+            queueENDs qIds . IM.lookup cId =<< readTVarIO cls
+        queueENDs qIds = \case
+          Just (Just c) -> forkClient c ("sendPendingENDsThread.queueENDs") $ do
+            stats <- asks serverStats
+            atomically $ writeTBQueue (sndQ c) $ L.map (CorrId "",,END) qIds
+            let len = L.length qIds
+            liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len)
+            liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs in the batch
+          _ -> pure ()
+
     receiveFromProxyAgent :: ProxyAgent -> M ()
     receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} =
       forever $
@@ -223,9 +246,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
         old <- liftIO $ expireBeforeEpoch expCfg
         rIds <- M.keysSet <$> readTVarIO ms
         forM_ rIds $ \rId -> do
-          q <- atomically (getMsgQueue ms rId quota)
+          q <- liftIO $ getMsgQueue ms rId quota
           deleted <- atomically $ deleteExpiredMsgs q old
-          atomically $ modifyTVar' (msgExpired stats) (+ deleted)
+          liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted)
 
     serverStatsThread_ :: ServerConfig -> [M ()]
     serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -238,7 +261,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
       liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
-      ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubNoMsg, qSubAuth, qSubDuplicate, qSubProhibited, ntfCreated, ntfDeleted, ntfSub, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, subscribedQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv}
+      ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv}
         <- asks serverStats
       QueueStore {queues, notifiers} <- asks queueStore
       let interval = 1000000 * logInterval
@@ -246,51 +269,55 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
           hSetBuffering h LineBuffering
           ts <- getCurrentTime
-          fromTime' <- atomically $ swapTVar fromTime ts
-          qCreated' <- atomically $ swapTVar qCreated 0
-          qSecured' <- atomically $ swapTVar qSecured 0
-          qDeletedAll' <- atomically $ swapTVar qDeletedAll 0
-          qDeletedNew' <- atomically $ swapTVar qDeletedNew 0
-          qDeletedSecured' <- atomically $ swapTVar qDeletedSecured 0
-          qSub' <- atomically $ swapTVar qSub 0
-          qSubNoMsg' <- atomically $ swapTVar qSubNoMsg 0
-          qSubAuth' <- atomically $ swapTVar qSubAuth 0
-          qSubDuplicate' <- atomically $ swapTVar qSubDuplicate 0
-          qSubProhibited' <- atomically $ swapTVar qSubProhibited 0
-          ntfCreated' <- atomically $ swapTVar ntfCreated 0
-          ntfDeleted' <- atomically $ swapTVar ntfDeleted 0
-          ntfSub' <- atomically $ swapTVar ntfSub 0
-          ntfSubAuth' <- atomically $ swapTVar ntfSubAuth 0
-          ntfSubDuplicate' <- atomically $ swapTVar ntfSubDuplicate 0
-          msgSent' <- atomically $ swapTVar msgSent 0
-          msgSentAuth' <- atomically $ swapTVar msgSentAuth 0
-          msgSentQuota' <- atomically $ swapTVar msgSentQuota 0
-          msgSentLarge' <- atomically $ swapTVar msgSentLarge 0
-          msgRecv' <- atomically $ swapTVar msgRecv 0
-          msgRecvGet' <- atomically $ swapTVar msgRecvGet 0
-          msgGet' <- atomically $ swapTVar msgGet 0
-          msgGetNoMsg' <- atomically $ swapTVar msgGetNoMsg 0
-          msgGetAuth' <- atomically $ swapTVar msgGetAuth 0
-          msgGetDuplicate' <- atomically $ swapTVar msgGetDuplicate 0
-          msgGetProhibited' <- atomically $ swapTVar msgGetProhibited 0
-          msgExpired' <- atomically $ swapTVar msgExpired 0
-          ps <- atomically $ periodStatCounts activeQueues ts
-          psSub <- atomically $ periodStatCounts subscribedQueues ts
-          msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
-          msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
-          psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
-          msgNtfs' <- atomically $ swapTVar (msgNtfs ss) 0
-          msgNtfNoSub' <- atomically $ swapTVar (msgNtfNoSub ss) 0
-          msgNtfLost' <- atomically $ swapTVar (msgNtfLost ss) 0
-          pRelays' <- atomically $ getResetProxyStatsData pRelays
-          pRelaysOwn' <- atomically $ getResetProxyStatsData pRelaysOwn
-          pMsgFwds' <- atomically $ getResetProxyStatsData pMsgFwds
-          pMsgFwdsOwn' <- atomically $ getResetProxyStatsData pMsgFwdsOwn
-          pMsgFwdsRecv' <- atomically $ swapTVar pMsgFwdsRecv 0
-          qCount' <- readTVarIO qCount
+          fromTime' <- atomicSwapIORef fromTime ts
+          qCreated' <- atomicSwapIORef qCreated 0
+          qSecured' <- atomicSwapIORef qSecured 0
+          qDeletedAll' <- atomicSwapIORef qDeletedAll 0
+          qDeletedAllB' <- atomicSwapIORef qDeletedAllB 0
+          qDeletedNew' <- atomicSwapIORef qDeletedNew 0
+          qDeletedSecured' <- atomicSwapIORef qDeletedSecured 0
+          qSub' <- atomicSwapIORef qSub 0
+          qSubAllB' <- atomicSwapIORef qSubAllB 0
+          qSubAuth' <- atomicSwapIORef qSubAuth 0
+          qSubDuplicate' <- atomicSwapIORef qSubDuplicate 0
+          qSubProhibited' <- atomicSwapIORef qSubProhibited 0
+          qSubEnd' <- atomicSwapIORef qSubEnd 0
+          qSubEndB' <- atomicSwapIORef qSubEndB 0
+          ntfCreated' <- atomicSwapIORef ntfCreated 0
+          ntfDeleted' <- atomicSwapIORef ntfDeleted 0
+          ntfDeletedB' <- atomicSwapIORef ntfDeletedB 0
+          ntfSub' <- atomicSwapIORef ntfSub 0
+          ntfSubB' <- atomicSwapIORef ntfSubB 0
+          ntfSubAuth' <- atomicSwapIORef ntfSubAuth 0
+          ntfSubDuplicate' <- atomicSwapIORef ntfSubDuplicate 0
+          msgSent' <- atomicSwapIORef msgSent 0
+          msgSentAuth' <- atomicSwapIORef msgSentAuth 0
+          msgSentQuota' <- atomicSwapIORef msgSentQuota 0
+          msgSentLarge' <- atomicSwapIORef msgSentLarge 0
+          msgRecv' <- atomicSwapIORef msgRecv 0
+          msgRecvGet' <- atomicSwapIORef msgRecvGet 0
+          msgGet' <- atomicSwapIORef msgGet 0
+          msgGetNoMsg' <- atomicSwapIORef msgGetNoMsg 0
+          msgGetAuth' <- atomicSwapIORef msgGetAuth 0
+          msgGetDuplicate' <- atomicSwapIORef msgGetDuplicate 0
+          msgGetProhibited' <- atomicSwapIORef msgGetProhibited 0
+          msgExpired' <- atomicSwapIORef msgExpired 0
+          ps <- liftIO $ periodStatCounts activeQueues ts
+          msgSentNtf' <- atomicSwapIORef msgSentNtf 0
+          msgRecvNtf' <- atomicSwapIORef msgRecvNtf 0
+          psNtf <- liftIO $ periodStatCounts activeQueuesNtf ts
+          msgNtfs' <- atomicSwapIORef (msgNtfs ss) 0
+          msgNtfNoSub' <- atomicSwapIORef (msgNtfNoSub ss) 0
+          msgNtfLost' <- atomicSwapIORef (msgNtfLost ss) 0
+          pRelays' <- getResetProxyStatsData pRelays
+          pRelaysOwn' <- getResetProxyStatsData pRelaysOwn
+          pMsgFwds' <- getResetProxyStatsData pMsgFwds
+          pMsgFwdsOwn' <- getResetProxyStatsData pMsgFwdsOwn
+          pMsgFwdsRecv' <- atomicSwapIORef pMsgFwdsRecv 0
+          qCount' <- readIORef qCount
           qCount'' <- M.size <$> readTVarIO queues
           ntfCount' <- M.size <$> readTVarIO notifiers
-          msgCount' <- readTVarIO msgCount
+          msgCount' <- readIORef msgCount
           hPutStrLn h $
             intercalate
               ","
@@ -329,23 +356,31 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                        show msgNtfs',
                        show msgNtfNoSub',
                        show msgNtfLost',
-                       show qSubNoMsg',
+                       "0", -- qSubNoMsg' is removed for performance.
+                       -- Use qSubAllB for the approximate number of all subscriptions.
+                       -- Average observed batch size is 25-30 subscriptions.
                        show msgRecvGet',
                        show msgGet',
                        show msgGetNoMsg',
                        show msgGetAuth',
                        show msgGetDuplicate',
                        show msgGetProhibited',
-                       dayCount psSub,
-                       weekCount psSub,
-                       monthCount psSub,
+                       "0", -- dayCount psSub; psSub is removed to reduce memory usage
+                       "0", -- weekCount psSub
+                       "0", -- monthCount psSub
                        show qCount'',
                        show ntfCreated',
                        show ntfDeleted',
                        show ntfSub',
                        show ntfSubAuth',
                        show ntfSubDuplicate',
-                       show ntfCount'
+                       show ntfCount',
+                       show qDeletedAllB',
+                       show qSubAllB',
+                       show qSubEnd',
+                       show qSubEndB',
+                       show ntfDeletedB',
+                       show ntfSubB'
                      ]
               )
         liftIO $ threadDelay' interval
@@ -422,9 +457,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                   hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
               CPStats -> withUserRole $ do
                 ss <- unliftIO u $ asks serverStats
-                let getStat :: (ServerStats -> TVar a) -> IO a
-                    getStat var = readTVarIO (var ss)
-                    putStat :: Show a => String -> (ServerStats -> TVar a) -> IO ()
+                let getStat :: (ServerStats -> IORef a) -> IO a
+                    getStat var = readIORef (var ss)
+                    putStat :: Show a => String -> (ServerStats -> IORef a) -> IO ()
                     putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v
                     putProxyStat :: String -> (ServerStats -> ProxyStats) -> IO ()
                     putProxyStat label var = do
@@ -434,12 +469,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                 putStat "qCreated" qCreated
                 putStat "qSecured" qSecured
                 putStat "qDeletedAll" qDeletedAll
+                putStat "qDeletedAllB" qDeletedAllB
                 putStat "qDeletedNew" qDeletedNew
                 putStat "qDeletedSecured" qDeletedSecured
                 getStat (day . activeQueues) >>= \v -> hPutStrLn h $ "daily active queues: " <> show (S.size v)
-                getStat (day . subscribedQueues) >>= \v -> hPutStrLn h $ "daily subscribed queues: " <> show (S.size v)
+                -- removed to reduce memory usage
+                -- getStat (day . subscribedQueues) >>= \v -> hPutStrLn h $ "daily subscribed queues: " <> show (S.size v)
                 putStat "qSub" qSub
-                putStat "qSubNoMsg" qSubNoMsg
+                putStat "qSubAllB" qSubAllB
+                putStat "qSubEnd" qSubEnd
+                putStat "qSubEndB" qSubEndB
                 subs <- (,,) <$> getStat qSubAuth <*> getStat qSubDuplicate <*> getStat qSubProhibited
                 hPutStrLn h $ "other SUB events (auth, duplicate, prohibited): " <> show subs
                 putStat "msgSent" msgSent
@@ -680,9 +719,21 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
     atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime
     stats <- asks serverStats
     (errs, cmds) <- partitionEithers <$> mapM (cmdAction stats) ts
+    updateBatchStats stats cmds
     write sndQ errs
     write rcvQ cmds
   where
+    updateBatchStats :: ServerStats -> [(Maybe QueueRec, Transmission Cmd)] -> M ()
+    updateBatchStats stats = \case
+      (_, (_, _, (Cmd _ cmd))) : _ -> do
+        let sel_ = case cmd of
+              SUB -> Just qSubAllB
+              DEL -> Just qDeletedAllB
+              NSUB -> Just ntfSubB
+              NDEL -> Just ntfDeletedB
+              _ -> Nothing
+        mapM_ (\sel -> incStat $ sel stats) sel_
+      [] -> pure ()
     cmdAction :: ServerStats -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
     cmdAction stats (tAuth, authorized, (corrId, entId, cmdOrError)) =
       case cmdOrError of
@@ -711,7 +762,7 @@ send th c@Client {sndQ, msgQ, sessionId} = do
       | L.length ts <= 2 = tSend th c ts
       | otherwise = do
           let (msgs_, ts') = mapAccumR splitMessages [] ts
-          -- If the request had batched subscriptions (L.length ts > 2)
+          -- If the request had batched subscriptions and L.length ts > 2
           -- this will reply OK to all SUBs in the first batched transmission,
           -- to reduce client timeouts.
           tSend th c ts'
@@ -725,7 +776,7 @@ send th c@Client {sndQ, msgQ, sessionId} = do
           -- replace MSG response with OK, accumulating MSG in a separate list.
           MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK))
           _ -> (msgs, t)
-
+        
 sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
 sendMsg th c@Client {msgQ, sessionId} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " sendMsg"
@@ -847,7 +898,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
     reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m ()
     reply = atomically . writeTBQueue sndQ
     processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (Maybe (Transmission BrokerMsg))
-    processProxiedCmd (corrId, sessId, command) = (corrId,sessId,) <$$> case command of
+    processProxiedCmd (corrId, EntityId sessId, command) = (corrId,EntityId sessId,) <$$> case command of
       PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH)
         where
           allowProxy = do
@@ -910,7 +961,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
         forkProxiedCmd cmdAction = do
           bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do
             -- commands MUST be processed under a reasonable timeout or the client would halt
-            cmdAction >>= \t -> reply [(corrId, sessId, t)]
+            cmdAction >>= \t -> reply [(corrId, EntityId sessId, t)]
           pure Nothing
           where
             wait = do
@@ -922,7 +973,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
             signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
     transportErr :: TransportError -> ErrorType
     transportErr = PROXY . BROKER . TRANSPORT
-    mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m ()
+    mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> IORef Int) -> m ()
     mkIncProxyStats ps psOwn own sel = do
       incStat $ sel ps
       when own $ incStat $ sel psOwn
@@ -936,8 +987,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
             | otherwise -> pure $ ERR AUTH
           Nothing -> pure $ ERR INTERNAL
         SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
-        PING -> pure (corrId, "", PONG)
-        RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock
+        PING -> pure (corrId, NoEntity, PONG)
+        RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock
       Cmd SNotifier NSUB -> Just <$> subscribeNotifications
       Cmd SRecipient command -> do
         st <- asks queueStore
@@ -1080,10 +1131,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
             deliver inc sub = do
               q <- getStoreMsgQueue "SUB" rId
               msg_ <- atomically $ tryPeekMsg q
-              when inc $ do
-                stats <- asks serverStats
-                incStat $ (if isJust msg_ then qSub else qSubNoMsg) stats
-                atomically $ updatePeriodStats (subscribedQueues stats) rId
+              when (inc && isJust msg_) $
+                incStat . qSub =<< asks serverStats
               deliverMessage "SUB" qr rId sub msg_
 
         getMessage :: QueueRec -> M (Transmission BrokerMsg)
@@ -1172,11 +1221,11 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
                 stats <- asks serverStats
                 incStat $ msgRecv stats
                 when isGet $ incStat $ msgRecvGet stats
-                atomically $ modifyTVar' (msgCount stats) (subtract 1)
-                atomically $ updatePeriodStats (activeQueues stats) entId
+                liftIO $ atomicModifyIORef'_ (msgCount stats) (subtract 1)
+                liftIO $ updatePeriodStats (activeQueues stats) entId
                 when (notification msgFlags) $ do
                   incStat $ msgRecvNtf stats
-                  atomically $ updatePeriodStats (activeQueuesNtf stats) entId
+                  liftIO $ updatePeriodStats (activeQueuesNtf stats) entId
 
         sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg)
         sendMessage qr msgFlags msgBody
@@ -1205,26 +1254,18 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
                         Just (msg, wasEmpty) -> time "SEND ok" $ do
                           when wasEmpty $ tryDeliverMessage msg
                           when (notification msgFlags) $ do
-                            forM_ (notifier qr) $ \ntf -> do
-                              asks random >>= atomically . trySendNotification ntf msg >>= \case
-                                Nothing -> do
-                                  incStat $ msgNtfNoSub stats
-                                  logWarn "No notification subscription"
-                                Just False -> do
-                                  incStat $ msgNtfLost stats
-                                  logWarn "Dropped message notification"
-                                Just True -> incStat $ msgNtfs stats
+                            mapM_ (`trySendNotification` msg) (notifier qr)
                             incStat $ msgSentNtf stats
-                            atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
+                            liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
                           incStat $ msgSent stats
                           incStat $ msgCount stats
-                          atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
+                          liftIO $ updatePeriodStats (activeQueues stats) (recipientId qr)
                           pure ok
           where
             THandleParams {thVersion} = thParams'
             mkMessage :: C.MaxLenBS MaxMessageLen -> M Message
             mkMessage body = do
-              msgId <- randomId =<< asks (msgIdBytes . config)
+              msgId <- randomId' =<< asks (msgIdBytes . config)
               msgTs <- liftIO getSystemTime
               pure $! Message msgId msgTs msgFlags body
 
@@ -1235,7 +1276,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
               deleted <- atomically $ sum <$> mapM (deleteExpiredMsgs q) old
               when (deleted > 0) $ do
                 stats <- asks serverStats
-                atomically $ modifyTVar' (msgExpired stats) (+ deleted)
+                liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted)
 
             -- The condition for delivery of the message is:
             -- - the queue was empty when the message was sent,
@@ -1270,7 +1311,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
                   void $ setDelivered s msg
                 forkDeliver (rc@Client {sndQ = q}, s@Sub {delivered}, st) = do
                   t <- mkWeakThreadId =<< forkIO deliverThread
-                  atomically . modifyTVar' st $ \case
+                  atomically $ modifyTVar' st $ \case
                     -- this case is needed because deliverThread can exit before it
                     SubPending -> SubThread t
                     st' -> st'
@@ -1285,23 +1326,35 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
                               deliver q s
                               writeTVar st NoSub
 
-            trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool)
-            trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg =
-              mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
+            trySendNotification :: NtfCreds -> Message -> M ()
+            trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg = do
+              stats <- asks serverStats
+              liftIO (TM.lookupIO notifierId notifiers) >>= \case
+                Nothing -> do
+                  incStat $ msgNtfNoSub stats
+                  logWarn "No notification subscription"
+                Just ntfClnt -> do
+                  let updateStats True = incStat $ msgNtfs stats
+                      updateStats _ = do
+                        incStat $ msgNtfLost stats
+                        logWarn "Dropped message notification"
+                  writeNtf notifierId msg rcvNtfDhSecret ntfClnt >>= mapM_ updateStats
 
-            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM Bool
-            writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
-              ifM (isFullTBQueue q) (pure False) (sendNtf $> True)
-              where
-                sendNtf = case msg of
-                  Message {msgId, msgTs} -> do
-                    (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
-                    writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
-                  _ -> pure ()
+            writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> Client -> M (Maybe Bool)
+            writeNtf nId msg rcvNtfDhSecret Client {sndQ = q} = case msg of
+              Message {msgId, msgTs} -> Just <$> do
+                (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret
+                -- must be in one STM transaction to avoid the queue becoming full between the check and writing
+                atomically $
+                  ifM
+                    (isFullTBQueue q)
+                    (pure $ False)
+                    (True <$ writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)])
+              _ -> pure Nothing
 
-            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
-            mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do
-              cbNonce <- C.randomCbNonce ntfNonceDrg
+            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M (C.CbNonce, EncNMsgMeta)
+            mkMessageNotification msgId msgTs rcvNtfDhSecret = do
+              cbNonce <- atomically . C.randomCbNonce =<< asks random
               let msgMeta = NMsgMeta {msgId, msgTs}
                   encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
               pure . (cbNonce,) $ fromRight "" encNMsgMeta
@@ -1391,7 +1444,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
         getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
           ms <- asks msgStore
           quota <- asks $ msgQueueQuota . config
-          atomically $ getMsgQueue ms rId quota
+          liftIO $ getMsgQueue ms rId quota
 
         delQueueAndMsgs :: QueueStore -> M (Transmission BrokerMsg)
         delQueueAndMsgs st = do
@@ -1401,31 +1454,31 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
             Right q -> do
               -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
               atomically $ writeTQueue subscribedQ (entId, clnt, False)
-              atomically $ writeTQueue ntfSubscribedQ (entId, clnt, False)
+              forM_ (notifierId <$> notifier q) $ \nId ->
+                atomically $ writeTQueue ntfSubscribedQ (nId, clnt, False)
               updateDeletedStats q
               pure ok
             Left e -> pure $ err e
 
         getQueueInfo :: QueueRec -> M (Transmission BrokerMsg)
         getQueueInfo QueueRec {senderKey, notifier} = do
-          q@MsgQueue {size} <- getStoreMsgQueue "getQueueInfo" entId
-          info <- atomically $ do
-            qiSub <- TM.lookup entId subscriptions >>= mapM mkQSub
-            qiSize <- readTVar size
-            qiMsg <- toMsgInfo <$$> tryPeekMsg q
-            pure QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
+          q <- getStoreMsgQueue "getQueueInfo" entId
+          qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub
+          qiSize <- liftIO $ getQueueSize q
+          qiMsg <- atomically $ toMsgInfo <$$> tryPeekMsg q
+          let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
           pure (corrId, entId, INFO info)
           where
             mkQSub Sub {subThread, delivered} = do
               qSubThread <- case subThread of
                 ServerSub t -> do
-                  st <- readTVar t
+                  st <- readTVarIO t
                   pure $ case st of
                     NoSub -> QNoSub
                     SubPending -> QSubPending
                     SubThread _ -> QSubThread
                 ProhibitSub -> pure QProhibitSub
-              qDelivered <- decodeLatin1 . encode <$$> tryReadTMVar delivered
+              qDelivered <- atomically $ decodeLatin1 . encode <$$> tryReadTMVar delivered
               pure QSub {qSubThread, qDelivered}
 
         ok :: Transmission BrokerMsg
@@ -1445,8 +1498,8 @@ updateDeletedStats q = do
   incStat $ qDeletedAll stats
   incStat $ qCount stats
 
-incStat :: MonadIO m => TVar Int -> m ()
-incStat v = atomically $ modifyTVar' v (+ 1)
+incStat :: MonadIO m => IORef Int -> m ()
+incStat r = liftIO $ atomicModifyIORef'_ r (+ 1)
 {-# INLINE incStat #-}
 
 withLog :: (StoreLog 'WriteMode -> IO a) -> M ()
@@ -1455,7 +1508,7 @@ withLog action = do
   liftIO . mapM_ action $ storeLog (env :: Env)
 
 timed :: T.Text -> RecipientId -> M a -> M a
-timed name qId a = do
+timed name (EntityId qId) a = do
   t <- liftIO getSystemTime
   r <- a
   t' <- liftIO getSystemTime
@@ -1466,8 +1519,12 @@ timed name qId a = do
     diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t)
     sec = 1000_000000
 
-randomId :: Int -> M ByteString
-randomId n = atomically . C.randomBytes n =<< asks random
+randomId' :: Int -> M ByteString
+randomId' n = atomically . C.randomBytes n =<< asks random
+
+randomId :: Int -> M EntityId
+randomId = fmap EntityId . randomId'
+{-# INLINE randomId #-}
 
 saveServerMessages :: Bool -> M ()
 saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages
@@ -1513,13 +1570,12 @@ restoreServerMessages =
           where
             s = LB.toStrict s'
             addToMsgQueue rId msg = do
-              (isExpired, logFull) <- atomically $ do
-                q <- getMsgQueue ms rId quota
-                case msg of
-                  Message {msgTs}
-                    | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q msg
-                    | otherwise -> pure (True, False)
-                  MessageQuota {} -> writeMsg q msg $> (False, False)
+              q <- liftIO $ getMsgQueue ms rId quota
+              (isExpired, logFull) <- atomically $ case msg of
+                Message {msgTs}
+                  | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q msg
+                  | otherwise -> pure (True, False)
+                MessageQuota {} -> writeMsg q msg $> (False, False)
               when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg)
               pure $ if isExpired then expired + 1 else expired
             msgErr :: Show e => String -> e -> String
@@ -1544,8 +1600,8 @@ restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config)
         Right d@ServerStatsData {_qCount = statsQCount} -> do
           s <- asks serverStats
           _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore
-          _msgCount <- foldM (\(!n) q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore
-          atomically $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring}
+          _msgCount <- liftIO . foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 =<< readTVarIO =<< asks msgStore
+          liftIO $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring}
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
           when (_qCount /= statsQCount) $ logWarn $ "Queue count differs: stats: " <> tshow statsQCount <> ", store: " <> tshow _qCount

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

@@ -12,6 +12,7 @@ import Control.Logger.Simple
 import Control.Monad
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.IORef
 import Data.Int (Int64)
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
@@ -76,6 +77,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,
@@ -138,6 +141,8 @@ data Server = Server
     subscribers :: TMap RecipientId Client,
     ntfSubscribedQ :: TQueue (NotifierId, Client, Subscribed),
     notifiers :: TMap NotifierId Client,
+    pendingENDs :: IORef (IntMap (NonEmpty RecipientId)),
+    pendingNtfENDs :: IORef (IntMap (NonEmpty NotifierId)),
     savingLock :: Lock
   }
 
@@ -180,8 +185,10 @@ newServer = do
   subscribers <- TM.emptyIO
   ntfSubscribedQ <- newTQueueIO
   notifiers <- TM.emptyIO
+  pendingENDs <- newIORef IM.empty
+  pendingNtfENDs <- newIORef IM.empty
   savingLock <- atomically createLock
-  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
+  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, pendingENDs, pendingNtfENDs, savingLock}
 
 newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
 newClient clientId qSize thVersion sessionId createdAt = do

src/Simplex/Messaging/Server/Main.hs

@@ -289,6 +289,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

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

@@ -9,7 +9,7 @@
 
 module Simplex.Messaging.Server.MsgStore.STM
   ( STMMsgStore,
-    MsgQueue (..),
+    MsgQueue (msgQueue),
     newMsgStore,
     getMsgQueue,
     delMsgQueue,
@@ -20,6 +20,7 @@ module Simplex.Messaging.Server.MsgStore.STM
     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
@@ -117,3 +123,6 @@ 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/Stats.hs

@@ -4,65 +4,74 @@
 {-# 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 qualified Data.ByteString.Char8 as B
+import Data.IORef
 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.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,
+  { 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 RecipientId,
-    subscribedQueues :: PeriodStats RecipientId,
-    msgSentNtf :: TVar Int, -- sent messages with NTF flag
-    msgRecvNtf :: TVar Int, -- received messages with NTF flag
+    -- subscribedQueues :: PeriodStats RecipientId, -- this stat uses too much memory
+    msgSentNtf :: IORef Int, -- sent messages with NTF flag
+    msgRecvNtf :: IORef 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
+    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 +79,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,
@@ -95,7 +109,6 @@ data ServerStatsData = ServerStatsData
     _msgGetProhibited :: Int,
     _msgExpired :: Int,
     _activeQueues :: PeriodStatsData RecipientId,
-    _subscribedQueues :: PeriodStatsData RecipientId,
     _msgSentNtf :: Int,
     _msgRecvNtf :: Int,
     _activeQueuesNtf :: PeriodStatsData RecipientId,
@@ -114,65 +127,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 +210,6 @@ newServerStats ts = do
         msgGetProhibited,
         msgExpired,
         activeQueues,
-        subscribedQueues,
         msgSentNtf,
         msgRecvNtf,
         activeQueuesNtf,
@@ -206,65 +227,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 +310,6 @@ getServerStatsData s = do
         _msgGetProhibited,
         _msgExpired,
         _activeQueues,
-        _subscribedQueues,
         _msgSentNtf,
         _msgRecvNtf,
         _activeQueuesNtf,
@@ -296,51 +325,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 +385,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 +420,6 @@ instance StrEncoding ServerStatsData where
         "msgNtfLost=" <> strEncode (_msgNtfLost d),
         "activeQueues:",
         strEncode (_activeQueues d),
-        "subscribedQueues:",
-        strEncode (_subscribedQueues d),
         "activeQueuesNtf:",
         strEncode (_activeQueuesNtf d),
         "pRelays:",
@@ -402,15 +439,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 +483,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 RecipientId) <* optional A.endOfLine)
         _ -> pure newPeriodStatsData
     _activeQueuesNtf <-
       optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
@@ -457,16 +500,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 +535,6 @@ instance StrEncoding ServerStatsData where
           _msgNtfNoSub,
           _msgNtfLost,
           _activeQueues,
-          _subscribedQueues,
           _activeQueuesNtf,
           _pRelays,
           _pRelaysOwn,
@@ -499,22 +546,23 @@ 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)
+  { day :: IORef (Set a),
+    week :: IORef (Set a),
+    month :: IORef (Set a)
   }
 
 newPeriodStats :: IO (PeriodStats a)
 newPeriodStats = do
-  day <- newTVarIO S.empty
-  week <- newTVarIO S.empty
-  month <- newTVarIO S.empty
+  day <- newIORef S.empty
+  week <- newIORef S.empty
+  month <- newIORef S.empty
   pure PeriodStats {day, week, month}
 
 data PeriodStatsData a = PeriodStatsData
@@ -529,16 +577,17 @@ newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month =
 
 getPeriodStatsData :: PeriodStats a -> IO (PeriodStatsData a)
 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 a -> PeriodStatsData a -> 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
   strEncode PeriodStatsData {_day, _week, _month} =
@@ -555,7 +604,7 @@ data PeriodStatCounts = PeriodStatCounts
     monthCount :: String
   }
 
-periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
+periodStatCounts :: forall a. PeriodStats a -> UTCTime -> IO PeriodStatCounts
 periodStatCounts ps ts = do
   let d = utctDay ts
       (_, wDay) = mondayStartWeek d
@@ -565,33 +614,33 @@ 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 (Set a) -> IO String
+    periodCount 1 ref = show . S.size <$> atomicSwapIORef ref S.empty
     periodCount _ _ = pure ""
 
-updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
-updatePeriodStats stats pId = do
-  updatePeriod day
-  updatePeriod week
-  updatePeriod month
+updatePeriodStats :: Ord a => PeriodStats a -> a -> IO ()
+updatePeriodStats ps pId = do
+  updatePeriod $ day ps
+  updatePeriod $ week ps
+  updatePeriod $ month ps
   where
-    updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)
+    updatePeriod ref = unlessM (S.member pId <$> readIORef ref) $ atomicModifyIORef'_ ref $ S.insert pId
 
 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 +657,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/Transport.hs

@@ -116,7 +116,6 @@ 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
 

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
 

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

@@ -1063,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)

tests/AgentTests/NotificationTests.hs

@@ -508,7 +508,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
   suspendAgent alice 0
   closeSQLiteStore store
   threadDelay 1000000
-  print "before opening the database from another agent"
+  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
@@ -516,7 +516,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
     pure ()
 
   threadDelay 1000000
-  print "after closing the database in another agent"
+  putStrLn "after closing the database in another agent"
   reopenSQLiteStore store
   foregroundAgent alice
   threadDelay 500000

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
@@ -217,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,
@@ -240,7 +240,7 @@ sndQueue1 =
     { userId = 1,
       connId = "conn1",
       server = smpServer1,
-      sndId = "3456",
+      sndId = EntityId "3456",
       sndSecure = True,
       sndPublicKey = testPublicAuthKey,
       sndPrivateKey = testPrivateAuthKey,
@@ -332,7 +332,7 @@ 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
@@ -400,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,
@@ -429,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,
@@ -661,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
@@ -715,7 +715,7 @@ rcvFileDescr1 =
     }
   where
     defaultChunkSize = FileSize $ mb 8
-    replicaId = ChunkReplicaId "abc"
+    replicaId = ChunkReplicaId $ EntityId "abc"
     chunkDigest = FileDigest "ghi"
 
 testFileSbKey :: C.SbKey
@@ -785,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
@@ -818,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/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

@@ -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")

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

@@ -34,7 +34,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
@@ -408,14 +408,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

@@ -78,13 +78,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 +134,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 +199,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 +271,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 +289,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 +299,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 +315,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 +354,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"
@@ -491,12 +491,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 +580,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 +610,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 +628,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 +647,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
 
@@ -684,10 +684,10 @@ 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 +742,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 +771,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 +793,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 +806,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 $

tests/XFTPServerTests.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module XFTPServerTests where
@@ -20,13 +21,13 @@ import Data.List (isInfixOf)
 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 +75,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
@@ -267,9 +268,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