Merge branch 'master' into ab/pclient-disconnected

CHANGELOG.md

@@ -1,61 +1,3 @@
-# 6.0.3
-
-Agent:
-- fix possible stuck queue rotation (#1290).
-
-SMP server:
-- batch END responses when subscribed client switches to reduce server and client traffic.
-- reduce STM transactions for better performance.
-- add stats for END events and for SUB/DEL event batches.
-- remove "expensive" stats to save memory.
-
-# 6.0.2
-
-SMP agent:
-- fix stuck connection commands when a server is not responding.
-- store query errors, reduce slow query threshold to 1ms.
-
-Notification server:
-- reduce PING interval to 1 minute.
-- fix subscriptions disabled on race condition (only mark subscriptions with END status when received via the active connection).
-
-# 6.0.1
-
-SMP agent:
-- support changing user of the new connection.
-- do not start delivery workers when there are no messages to deliver.
-- enable notifications for all connections.
-- combine database transactions when subscribing.
-
-SMP server:
-- safe compacting of store log.
-- fix possible race when creating client that might lead to memory leak.
-
-Dependencies: upgrade tls to 1.9
-
-# 6.0.0
-
-Version 6.0.0.8
-
-Agent:
-- enabled fast handshake support.
-- batch-send multiple messages in each connection.
-- resume subscriptions as soon as agent moves to foreground or as network connection resumes.
-- "known" servers to determine whether to use SMP proxy.
-- retry on SMP proxy NO_SESSION error.
-- fixes to notification subscriptions.
-- persistent server statistics.
-- better concurrency.
-
-SMP server:
-- reduce threads usage.
-- additional statistics.
-- improve disabling inactive clients.
-- additional control port commands for monitoring.
-
-Notification server:
-- support onion-only SMP servers.
-
 # 5.8.2
 
 Agent:

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 '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
+&& 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
 ```
 
 ### Build from source

apps/ntf-server/Main.hs

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

install.sh

@@ -3,7 +3,8 @@ set -eu
 
 # Links to scripts/configs
 bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
-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}')"
+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"
@@ -25,8 +26,6 @@ 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"
@@ -66,13 +65,7 @@ ${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 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: "
+Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
 
 end="Installtion is complete!
 
@@ -83,64 +76,27 @@ 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() {
- 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
+ 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"
 }
 
 setup_users() {
- eval "user=\$user_${1}"
-
- useradd -M "$user" 2> /dev/null || true
-
- unset user
+ useradd -M "$user_smp" 2> /dev/null || true
+ useradd -M "$user_xftp" 2> /dev/null || true
 }
 
 setup_dirs() {
  # Unquoted varibles, so field splitting can occur
- 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
+ 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
 }
 
 setup_systemd() {
- 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
+ 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"
 }
 
 setup_scripts() {
@@ -154,62 +110,32 @@ 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" "${BLU}$logo${NC}" "$welcome"
+ printf "%b\n%b\n" "${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..."
- 
- for i in $setup; do
-  setup_bins "$i"
- done
- 
+ setup_bins
  printf "${GRN} Done!${NC}\n"
 
  printf "Creating users..."
-
- for i in $setup; do
-  setup_users "$i"
- done
-
+ setup_users
  printf "${GRN} Done!${NC}\n"
  
  printf "Creating directories..."
-
- for i in $setup; do
-  setup_dirs "$i"
- done
-
+ setup_dirs
  printf "${GRN} Done!${NC}\n"
 
  printf "Creating systemd services..."
-
- for i in $setup; do
-  setup_systemd "$i"
- done
-
+ setup_systemd
  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.3.0
+version: 6.0.0.1
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -47,7 +47,6 @@ dependencies:
   - direct-sqlcipher == 2.3.*
   - directory == 1.3.*
   - filepath == 1.4.*
-  - hashable == 1.4.*
   - hourglass == 0.2.*
   - http-types == 0.12.*
   - http2 >= 4.2.2 && < 4.3
@@ -70,7 +69,7 @@ dependencies:
   - temporary == 1.3.*
   - time == 1.12.*
   - time-manager == 0.0.*
-  - tls >= 1.9.0 && < 1.10
+  - tls >= 1.7.0 && < 1.8
   - transformers == 0.6.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*

protocol/xrcp.md

@@ -250,7 +250,7 @@ In pseudo-code:
 ```
 // session 1
 hostHelloSecret(1) = dhSecret(1)
-sessionSecret(1) = sha3-256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
+sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
 dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1))
 kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1))
 // kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO
@@ -262,7 +262,7 @@ dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n))
 
 // session n
 hostHelloSecret(n) = dhSecret(n)
-sessionSecret(n) = sha3-256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
+sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
 dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n))
 // controllerDhKey(n) is either from invitation or from multicast announcement
 kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n))

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

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

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

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

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

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

scripts/main/simplex-servers-uninstall

@@ -13,15 +13,11 @@ 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 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
+systemctl stop smp-server
+systemctl stop xftp-server
 
-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
+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
 
-userdel smp 2>/dev/null || true
-userdel xftp 2>/dev/null || true
+userdel smp && userdel xftp
 
 printf "Uninstallation is complete! Thanks for trying out SimpleX!\n"

scripts/main/simplex-servers-update

@@ -3,6 +3,8 @@ 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"
@@ -31,9 +33,6 @@ 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'
@@ -41,40 +40,8 @@ RED='\033[0;31m'
 NC='\033[0m'
 
 # Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version
-
-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
-}
+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}')"
 
 update_scripts() {
   curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
@@ -89,7 +56,6 @@ 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"
@@ -98,7 +64,6 @@ 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"
@@ -106,84 +71,75 @@ 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() {
-  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"
+  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"
 
-  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"
+  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"
   else
-    printf -- "- Updating %s service..." "$service"
-    mv "$path_tmp_systemd" "$path_systemd"
+    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"
     systemctl daemon-reload
     printf "${GRN}Done!${NC}\n"
   fi
-
-  unset service scripts_systemd path_systemd path_tmp_systemd
 }
 
 update_bins() {
-  service="${1}-server"
-  eval "bin=\$bin_${1}"
-  eval "path_bin=\$path_bin_${1}"
-
-  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 [ "$local_version" != "$remote_version" ]; then
-    if systemctl is-active --quiet "$service"; then
-      printf -- "- Stopping %s service..." "$service"
-      systemctl stop "$service"
+    if systemctl is-active --quiet smp-server; then
+      printf -- "- Stopping smp-server service..."
+      systemctl stop smp-server
       printf "${GRN}Done!${NC}\n"
 
-      printf -- "- Updating %s to %s..." "$service" "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
+      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 %s service..." "$service"
-      systemctl start "$service"
+      printf -- "- Starting smp-server service..."
+      systemctl start smp-server
       printf "${GRN}Done!${NC}\n"
     else
-      printf -- "- Updating %s to %s..." "$service" "$remote_version"
-      curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
+      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"
+    fi
+
+    if systemctl is-active --quiet xftp-server; then
+      printf -- "- Stopping xftp-server service..."
+      systemctl stop xftp-server
+      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 "${GRN}Done!${NC}\n"
+      
+      printf -- "- Starting xftp-server service..."
+      systemctl start xftp-server
+      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 "${GRN}Done!${NC}\n"
     fi
   else
-    printf -- "- ${YLW}%s is up-to-date${NC}.\n" "$service"
+    printf -- "- ${YLW}smp-server and xftp-server binaries is up-to-date${NC}.\n"
   fi
-
-  set_ver "$1"
-
-  unset service bin path_bin local_version
 }
 
 checks() {
@@ -191,11 +147,6 @@ 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() {
@@ -212,14 +163,10 @@ main() {
   fi
 
   printf "Updating systemd services...\n"
-  for i in $apps; do
-    update_systemd "$i"
-  done
+  update_systemd
   
-  printf "Updating simplex servers...\n"
-  for i in $apps; do
-    update_bins "$i"
-  done
+  printf "Updating simplex server binaries...\n"
+  update_bins
 
   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.3.0
+version:        6.0.0.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -167,8 +167,6 @@ library
       Simplex.Messaging.Server
       Simplex.Messaging.Server.CLI
       Simplex.Messaging.Server.Control
-      Simplex.Messaging.Server.DataLog
-      Simplex.Messaging.Server.DataStore
       Simplex.Messaging.Server.Env.STM
       Simplex.Messaging.Server.Expiration
       Simplex.Messaging.Server.Information
@@ -238,7 +236,6 @@ library
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -261,7 +258,7 @@ library
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -313,7 +310,6 @@ executable ntf-server
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -337,7 +333,7 @@ executable ntf-server
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -393,7 +389,6 @@ executable smp-server
     , directory ==1.3.*
     , file-embed
     , filepath ==1.4.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -417,7 +412,7 @@ executable smp-server
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -472,7 +467,6 @@ executable xftp
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -496,7 +490,7 @@ executable xftp
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -548,7 +542,6 @@ executable xftp-server
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 >=4.2.2 && <4.3
@@ -572,7 +565,7 @@ executable xftp-server
     , temporary ==1.3.*
     , time ==1.12.*
     , time-manager ==0.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
@@ -660,7 +653,6 @@ test-suite simplexmq-test
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
-    , hashable ==1.4.*
     , hourglass ==0.2.*
     , hspec ==2.11.*
     , hspec-core ==2.11.*
@@ -689,7 +681,7 @@ test-suite simplexmq-test
     , time ==1.12.*
     , time-manager ==0.0.*
     , timeit ==2.0.*
-    , tls >=1.9.0 && <1.10
+    , tls >=1.7.0 && <1.8
     , transformers ==0.6.*
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*

src/Simplex/FileTransfer/Agent.hs

@@ -12,7 +12,6 @@
 
 module Simplex.FileTransfer.Agent
   ( startXFTPWorkers,
-    startXFTPSndWorkers,
     closeXFTPAgent,
     toFSFilePath,
     -- Receiving files
@@ -43,9 +42,9 @@ import Data.Either (partitionEithers, rights)
 import Data.Int (Int64)
 import Data.List (foldl', partition, sortOn)
 import qualified Data.List.NonEmpty as L
-import Data.Map.Strict (Map)
+import Data.Map (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (mapMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
@@ -74,7 +73,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 (ProtocolServer, ProtocolType (..), XFTPServer)
+import Simplex.Messaging.Protocol (EntityId, ProtocolServer, ProtocolType (..), XFTPServer)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM)
 import System.FilePath (takeFileName, (</>))
@@ -83,21 +82,13 @@ import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 
 startXFTPWorkers :: AgentClient -> Maybe FilePath -> AM ()
-startXFTPWorkers = startXFTPWorkers_ True
-{-# INLINE startXFTPWorkers #-}
-
-startXFTPSndWorkers :: AgentClient -> Maybe FilePath -> AM ()
-startXFTPSndWorkers = startXFTPWorkers_ False
-{-# INLINE startXFTPSndWorkers #-}
-
-startXFTPWorkers_ :: Bool -> AgentClient -> Maybe FilePath -> AM ()
-startXFTPWorkers_ allWorkers c workDir = do
+startXFTPWorkers c workDir = do
   wd <- asks $ xftpWorkDir . xftpAgent
   atomically $ writeTVar wd workDir
   cfg <- asks config
-  when allWorkers $ startRcvFiles cfg
+  startRcvFiles cfg
   startSndFiles cfg
-  when allWorkers $ startDelFiles cfg
+  startDelFiles cfg
   where
     startRcvFiles :: AgentConfig -> AM ()
     startRcvFiles AgentConfig {rcvFilesTTL} = do
@@ -184,18 +175,16 @@ runXFTPRcvWorker c srv Worker {doWork} = do
   cfg <- asks config
   forever $ do
     lift $ waitForWork doWork
-    liftIO $ assertAgentForeground c
+    atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
     runXFTPOperation :: AgentConfig -> AM ()
     runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} =
       withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case
-        (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _, redirectEntityId_) ->
-          rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) (INTERNAL "chunk has no replicas")
-        (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays, redirectEntityId_) -> do
+        (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas")
+        (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
-            liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
             atomically $ incXFTPServerStat c userId srv downloadAttempts
             downloadFileChunk fc replica approvedRelays
@@ -203,16 +192,16 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
-                when (serverHostError e) $ notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFWARN e)
+                when (serverHostError e) $ notify c rcvFileEntityId $ RFWARN e
                 liftIO $ closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
-              liftIO $ assertAgentForeground c
+              atomically $ assertAgentForeground c
               loop
             retryDone e = do
               atomically . incXFTPServerStat c userId srv $ case e of
                 XFTP _ XFTP.AUTH -> downloadAuthErrs
                 _ -> downloadErrs
-              rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) e
+              rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e
     downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM ()
     downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do
       unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED
@@ -222,7 +211,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           chunkSpec = XFTPRcvChunkSpec chunkPath chSize (unFileDigest digest)
           relChunkPath = fileTmpPath </> takeFileName chunkPath
       agentXFTPDownloadChunk c userId digest replica chunkSpec
-      liftIO $ waitUntilForeground c
+      atomically $ waitUntilForeground c
       (entityId, complete, progress) <- withStore c $ \db -> runExceptT $ do
         liftIO $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId relChunkPath
         RcvFile {size = FileSize currentSize, chunks, redirect} <- ExceptT $ getRcvFile db rcvFileId
@@ -241,7 +230,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
       where
         ipAddressProtected' :: AM Bool
         ipAddressProtected' = do
-          cfg <- liftIO $ getFastNetworkConfig c
+          cfg <- liftIO $ getNetworkConfig' c
           pure $ ipAddressProtected cfg srv
         receivedSize :: [RcvFileChunk] -> Int64
         receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0
@@ -263,25 +252,25 @@ retryOnError name loop done e = do
     then loop
     else done
 
-rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
-rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do
+rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
+rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do
   lift $ forM_ tmpPath (removePath <=< toFSFilePath)
   withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
-  notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err)
+  notify c rcvFileEntityId $ RFERR err
 
 runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM ()
 runXFTPRcvLocalWorker c Worker {doWork} = do
   cfg <- asks config
   forever $ do
     lift $ waitForWork doWork
-    liftIO $ assertAgentForeground c
+    atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
     runXFTPOperation :: AgentConfig -> AM ()
     runXFTPOperation AgentConfig {rcvFilesTTL} =
       withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
-        \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath, redirect} ->
-          decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
+        \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
+          decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath
     decryptFile :: RcvFile -> AM ()
     decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
       let CryptoFile savePath cfArgs = saveFile
@@ -300,12 +289,12 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
         Nothing -> do
           notify c rcvFileEntityId $ RFDONE fsSavePath
           lift $ forM_ tmpPath (removePath <=< toFSFilePath)
-          liftIO $ waitUntilForeground c
+          atomically $ waitUntilForeground c
           withStore' c (`updateRcvFileComplete` rcvFileId)
         Just RcvFileRedirect {redirectFileInfo, redirectDbId} -> do
           let RedirectFileInfo {size = redirectSize, digest = redirectDigest} = redirectFileInfo
           lift $ forM_ tmpPath (removePath <=< toFSFilePath)
-          liftIO $ waitUntilForeground c
+          atomically $ waitUntilForeground c
           withStore' c (`updateRcvFileComplete` rcvFileId)
           -- proceed with redirect
           yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
@@ -347,7 +336,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 -> AEntityId -> AEvent e -> m ()
+notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
 
 xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
@@ -393,7 +382,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
   cfg <- asks config
   forever $ do
     lift $ waitForWork doWork
-    liftIO $ assertAgentForeground c
+    atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
     runXFTPOperation :: AgentConfig -> AM ()
@@ -455,7 +444,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
           SndFileChunkReplica {server} : _ -> Right server
         createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
         createChunk numRecipients' ch = do
-          liftIO $ assertAgentForeground c
+          atomically $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate
           withStore' c $ \db -> createSndFileReplica db ch replica
           pure srv
@@ -463,9 +452,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
             tryCreate = do
               usedSrvs <- newTVarIO ([] :: [XFTPServer])
               let AgentClient {xftpServers} = c
-              userSrvCount <- liftIO $ length <$> TM.lookupIO userId xftpServers
+              userSrvCount <- length <$> atomically (TM.lookup userId xftpServers)
               withRetryIntervalCount (riFast ri) $ \n _ loop -> do
-                liftIO $ waitWhileSuspended c
                 liftIO $ waitForUserNetwork c
                 let triedAllSrvs = n > userSrvCount
                 createWithNextSrv usedSrvs
@@ -475,7 +463,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
                 retryLoop loop triedAllSrvs e = do
                   flip catchAgentError (\_ -> pure ()) $ do
                     when (triedAllSrvs && serverHostError e) $ notify c sndFileEntityId $ SFWARN e
-                  liftIO $ assertAgentForeground c
+                  atomically $ assertAgentForeground c
                   loop
             createWithNextSrv usedSrvs = do
               deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
@@ -495,7 +483,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
   cfg <- asks config
   forever $ do
     lift $ waitForWork doWork
-    liftIO $ assertAgentForeground c
+    atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
     runXFTPOperation :: AgentConfig -> AM ()
@@ -505,7 +493,6 @@ runXFTPSndWorker c srv Worker {doWork} = do
         fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
-            liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
             atomically $ incXFTPServerStat c userId srv uploadAttempts
             uploadFileChunk cfg fc replica
@@ -516,7 +503,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
                 when (serverHostError e) $ notify c sndFileEntityId $ SFWARN e
                 liftIO $ closeXFTPServerClient c userId server digest
                 withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
-              liftIO $ assertAgentForeground c
+              atomically $ assertAgentForeground c
               loop
             retryDone e = do
               atomically $ incXFTPServerStat c userId srv uploadErrs
@@ -527,9 +514,9 @@ runXFTPSndWorker c srv Worker {doWork} = do
       fsFilePath <- lift $ toFSFilePath filePath
       unlessM (doesFileExist fsFilePath) $ throwE $ FILE NO_FILE
       let chunkSpec' = chunkSpec {filePath = fsFilePath} :: XFTPChunkSpec
-      liftIO $ assertAgentForeground c
+      atomically $ assertAgentForeground c
       agentXFTPUploadChunk c userId chunkDigest replica' chunkSpec'
-      liftIO $ waitUntilForeground c
+      atomically $ waitUntilForeground c
       sf@SndFile {sndFileEntityId, prefixPath, chunks} <- withStore c $ \db -> do
         updateSndChunkReplicaStatus db sndChunkReplicaId SFRSUploaded
         getSndFile db sndFileId
@@ -667,7 +654,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
   cfg <- asks config
   forever $ do
     lift $ waitForWork doWork
-    liftIO $ assertAgentForeground c
+    atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
     runXFTPOperation :: AgentConfig -> AM ()
@@ -678,7 +665,6 @@ runXFTPDelWorker c srv Worker {doWork} = do
         processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do
           let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
-            liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
             atomically $ incXFTPServerStat c userId srv deleteAttempts
             deleteChunkReplica
@@ -689,7 +675,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
                 when (serverHostError e) $ notify c "" $ SFWARN e
                 liftIO $ closeXFTPServerClient c userId server chunkDigest
                 withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
-              liftIO $ assertAgentForeground c
+              atomically $ assertAgentForeground c
               loop
             retryDone e = do
               atomically $ incXFTPServerStat c userId srv deleteErrs
@@ -704,7 +690,7 @@ delWorkerInternalError c deletedSndChunkReplicaId e = do
   withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
   notify c "" $ SFERR e
 
-assertAgentForeground :: AgentClient -> IO ()
+assertAgentForeground :: AgentClient -> STM ()
 assertAgentForeground c = do
   throwWhenInactive c
   waitUntilForeground c

src/Simplex/FileTransfer/Client.hs

@@ -50,7 +50,6 @@ 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)
@@ -223,7 +222,7 @@ createXFTPChunk ::
   Maybe BasicAuth ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
 createXFTPChunk c spKey file rcps auth_ =
-  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case
+  sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case
     (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
     (r, _) -> throwE $ unexpectedResponse r
 
@@ -279,7 +278,7 @@ pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
 pingXFTP c@XFTPClient {thParams} = do
   t <-
     liftEither . first PCETransportError $
-      xftpEncodeTransmission thParams ("", NoEntity, FileCmd SFRecipient PING)
+      xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING)
   (r, _) <- sendXFTPTransmission c t Nothing
   case r of
     FRPong -> pure ()

src/Simplex/FileTransfer/Client/Agent.hs

@@ -53,9 +53,9 @@ defaultXFTPClientAgentConfig =
 data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
   deriving (Show, Exception)
 
-newXFTPAgent :: XFTPClientAgentConfig -> IO XFTPClientAgent
+newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent
 newXFTPAgent config = do
-  xftpClients <- TM.emptyIO
+  xftpClients <- TM.empty
   pure XFTPClientAgent {xftpClients, config}
 
 type ME a = ExceptT XFTPClientAgentError IO a

src/Simplex/FileTransfer/Client/Main.hs

@@ -43,8 +43,8 @@ import Data.Int (Int64)
 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.Strict as M
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import Data.Word (Word32)
@@ -313,7 +313,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
     uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
     uploadFile g chunks uploadedChunks encSize = do
-      a <- liftIO $ newXFTPAgent defaultXFTPClientAgentConfig
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       gen <- newTVarIO =<< liftIO newStdGen
       let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers)
       srvs <- liftIO $ replicateM (length chunks) $ getXFTPServer gen xftpSrvs
@@ -429,7 +429,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
     receive (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do
       encPath <- getEncPath tempPath "xftp"
       createDirectory encPath
-      a <- liftIO $ newXFTPAgent defaultXFTPClientAgentConfig
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       liftIO $ printNoNewLine "Downloading file..."
       downloadedChunks <- newTVarIO []
       let srv FileChunk {replicas} = case replicas of
@@ -494,7 +494,7 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
   where
     deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO ()
     deleteFile (ValidFileDescription FileDescription {chunks}) = do
-      a <- liftIO $ newXFTPAgent defaultXFTPClientAgentConfig
+      a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
       forM_ chunks $ deleteFileChunk a
       liftIO $ do
         printNoNewLine "File deleted!"

src/Simplex/FileTransfer/Description.hs

@@ -1,9 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -54,8 +52,8 @@ import Data.Int (Int64)
 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.Strict as M
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
 import Data.String
 import Data.Text (Text)
@@ -141,9 +139,12 @@ data FileChunkReplica = FileChunkReplica
   }
   deriving (Eq, Show)
 
-newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: XFTPFileId}
+newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: ByteString}
   deriving (Eq, Show)
-  deriving newtype (StrEncoding)
+
+instance StrEncoding ChunkReplicaId where
+  strEncode (ChunkReplicaId fid) = strEncode fid
+  strP = ChunkReplicaId <$> strP
 
 instance FromJSON ChunkReplicaId where
   parseJSON = strParseJSON "ChunkReplicaId"
@@ -152,6 +153,10 @@ 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,7 +41,6 @@ import Simplex.Messaging.Protocol
     ProtocolType (..),
     RcvPublicAuthKey,
     RcvPublicDhKey,
-    EntityId (..),
     RecipientId,
     SenderId,
     SentRawTransmission,
@@ -171,7 +170,7 @@ data FileInfo = FileInfo
   }
   deriving (Show)
 
-type XFTPFileId = EntityId
+type XFTPFileId = ByteString
 
 instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
@@ -192,7 +191,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
   fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of
+  checkCredentials (auth, _, fileId, _) cmd = case cmd of
     -- FNEW must not have signature and chunk ID
     FNEW {}
       | isNothing auth -> Left $ CMD NO_AUTH
@@ -302,7 +301,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials (_, _, entId, _) cmd = case cmd of
     FRSndIds {} -> noEntity
     -- ERR response does not always have entity ID
     FRErr _ -> Right cmd

src/Simplex/FileTransfer/Server.hs

@@ -9,7 +9,6 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -38,7 +37,6 @@ 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
@@ -54,7 +52,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 (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
+import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
@@ -65,7 +63,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runLocalTCPServer, tlsServerCredentials)
+import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Exit (exitFailure)
@@ -114,7 +112,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         Right pk' -> pure pk'
         Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
       env <- ask
-      sessions <- liftIO TM.emptyIO
+      sessions <- atomically TM.empty
       let cleanup sessionId = atomically $ TM.delete sessionId sessions
       liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
         reqBody <- getHTTP2Body r xftpBlockSize
@@ -209,17 +207,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
           hSetBuffering h LineBuffering
           ts <- getCurrentTime
-          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
+          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
           hPutStrLn h $
             intercalate
               ","
@@ -249,7 +247,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       u <- askUnliftIO
       liftIO $ do
         labelMyThread "control port server"
-        runLocalTCPServer cpStarted port $ runCPClient u
+        runTCPServer cpStarted port $ runCPClient u
       where
         runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
         runCPClient u sock = do
@@ -311,7 +309,7 @@ data ServerFile = ServerFile
 
 processRequest :: XFTPTransportRequest -> M ()
 processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
-  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
+  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
   | otherwise = do
       case xftpDecodeTransmission thParams bodyHead of
         Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
@@ -324,7 +322,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
             Left e -> send (FRErr e) Nothing
           where
             send resp = sendXFTPResponse (corrId, fId, resp)
-        Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
+        Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
   where
     sendXFTPResponse (corrId, fId, resp) serverFile_ = do
       let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
@@ -407,8 +405,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
           logAddFile sl sId file ts
           logAddRecipients sl sId rcps
         stats <- asks serverStats
-        lift $ incFileStat filesCreated
-        liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
+        atomically $ modifyTVar' (filesCreated stats) (+ 1)
+        atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRSndIds sId rIds
       pure $ either FRErr id r
@@ -437,7 +435,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         lift $ withFileLog $ \sl -> logAddRecipients sl sId rcps
         stats <- asks serverStats
-        liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
+        atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRRcvIds rIds
       pure $ either FRErr id r
@@ -465,19 +463,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 $ unEntityId senderId)
+            let fPath = path </> B.unpack (B64.encode senderId)
             receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case
               Right () -> do
                 stats <- asks serverStats
                 withFileLog $ \sl -> logPutFile sl senderId fPath
                 atomically $ writeTVar filePath (Just fPath)
-                incFileStat filesUploaded
-                incFileStat filesCount
-                liftIO $ atomicModifyIORef'_ (filesSize stats) (+ fromIntegral size)
+                atomically $ modifyTVar' (filesUploaded stats) (+ 1)
+                atomically $ modifyTVar' (filesCount stats) (+ 1)
+                atomically $ modifyTVar' (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
@@ -496,8 +494,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
               case LC.cbInit dhSecret cbNonce of
                 Right sbState -> do
                   stats <- asks serverStats
-                  incFileStat fileDownloads
-                  liftIO $ updatePeriodStats (filesDownloaded stats) senderId
+                  atomically $ modifyTVar' (fileDownloads stats) (+ 1)
+                  atomically $ updatePeriodStats (filesDownloaded stats) senderId
                   pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
                 _ -> pure (FRErr INTERNAL, Nothing)
         _ -> pure (FRErr NO_FILE, Nothing)
@@ -513,7 +511,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       withFileLog (`logAckFile` rId)
       st <- asks store
       atomically $ deleteRecipient st rId fr
-      incFileStat fileDownloadAcks
+      stats <- asks serverStats
+      atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1)
       pure FROk
 
 deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ())
@@ -525,11 +524,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
-    lift $ incFileStat filesDeleted
+    atomically $ modifyTVar' (filesDeleted stats) (+ 1)
   where
     deletedStats stats = do
-      liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
-      liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
+      atomically $ modifyTVar' (filesCount stats) (subtract 1)
+      atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
 expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
 expireServerFiles itemDelay expCfg = do
@@ -555,26 +554,29 @@ 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
-      incFileStat filesExpired
+      FileServerStats {filesExpired} <- asks serverStats
+      atomically $ modifyTVar' filesExpired (+ 1)
 
 randomId :: Int -> M ByteString
 randomId n = atomically . C.randomBytes n =<< asks random
 
 getFileId :: M XFTPFileId
-getFileId = fmap EntityId . randomId =<< asks (fileIdSize . config)
+getFileId = do
+  size <- asks (fileIdSize . config)
+  atomically . C.randomBytes size =<< asks random
 
 withFileLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withFileLog action = liftIO . mapM_ action =<< asks storeLog
 
-incFileStat :: (FileServerStats -> IORef Int) -> M ()
+incFileStat :: (FileServerStats -> TVar Int) -> M ()
 incFileStat statSel = do
   stats <- asks serverStats
-  liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
+  atomically $ modifyTVar (statSel stats) (+ 1)
 
 saveServerStats :: M ()
 saveServerStats =
   asks (serverStatsBackupFile . config)
-    >>= mapM_ (\f -> asks serverStats >>= liftIO . getFileServerStatsData >>= liftIO . saveStats f)
+    >>= mapM_ (\f -> asks serverStats >>= atomically . getFileServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
       logInfo $ "saving server stats to file " <> T.pack f
@@ -592,7 +594,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
           FileStore {files, usedStorage} <- asks store
           _filesCount <- M.size <$> readTVarIO files
           _filesSize <- readTVarIO usedStorage
-          liftIO $ setFileServerStats s d {_filesCount, _filesSize}
+          atomically $ 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 Simplex.FileTransfer.Protocol (XFTPFileId)
+import Data.ByteString (ByteString)
 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 XFTPFileId
+  | CPDelete ByteString
   | CPHelp
   | CPQuit
   | CPSkip

src/Simplex/FileTransfer/Server/Env.hs

@@ -11,6 +11,7 @@ module Simplex.FileTransfer.Server.Env where
 
 import Control.Logger.Simple
 import Control.Monad
+import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
@@ -104,17 +105,17 @@ supportedXFTPhandshakes = ["xftp/1"]
 
 newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
 newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
-  random <- C.newRandom
-  store <- newFileStore
-  storeLog <- mapM (`readWriteFileStore` store) storeLogFile
+  random <- liftIO C.newRandom
+  store <- atomically newFileStore
+  storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
   used <- countUsedStorage <$> readTVarIO (files store)
   atomically $ writeTVar (usedStorage store) used
   forM_ fileSizeQuota $ \quota -> do
     logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
     when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
-  tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
-  Fingerprint fp <- loadFingerprint caCertificateFile
-  serverStats <- newFileServerStats =<< getCurrentTime
+  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
+  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
+  serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
   pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 countUsedStorage :: M.Map k FileRec -> Int64

src/Simplex/FileTransfer/Server/Stats.hs

@@ -7,24 +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 :: IORef UTCTime,
-    filesCreated :: IORef Int,
-    fileRecipients :: IORef Int,
-    filesUploaded :: IORef Int,
-    filesExpired :: IORef Int,
-    filesDeleted :: IORef Int,
-    filesDownloaded :: PeriodStats,
-    fileDownloads :: IORef Int,
-    fileDownloadAcks :: IORef Int,
-    filesCount :: IORef Int,
-    filesSize :: IORef Int64
+  { fromTime :: TVar UTCTime,
+    filesCreated :: TVar Int,
+    fileRecipients :: TVar Int,
+    filesUploaded :: TVar Int,
+    filesExpired :: TVar Int,
+    filesDeleted :: TVar Int,
+    filesDownloaded :: PeriodStats SenderId,
+    fileDownloads :: TVar Int,
+    fileDownloadAcks :: TVar Int,
+    filesCount :: TVar Int,
+    filesSize :: TVar Int64
   }
 
 data FileServerStatsData = FileServerStatsData
@@ -34,7 +35,7 @@ data FileServerStatsData = FileServerStatsData
     _filesUploaded :: Int,
     _filesExpired :: Int,
     _filesDeleted :: Int,
-    _filesDownloaded :: PeriodStatsData,
+    _filesDownloaded :: PeriodStatsData SenderId,
     _fileDownloads :: Int,
     _fileDownloadAcks :: Int,
     _filesCount :: Int,
@@ -42,50 +43,49 @@ data FileServerStatsData = FileServerStatsData
   }
   deriving (Show)
 
-newFileServerStats :: UTCTime -> IO FileServerStats
+newFileServerStats :: UTCTime -> STM FileServerStats
 newFileServerStats ts = do
-  fromTime <- newIORef ts
-  filesCreated <- newIORef 0
-  fileRecipients <- newIORef 0
-  filesUploaded <- newIORef 0
-  filesExpired <- newIORef 0
-  filesDeleted <- newIORef 0
+  fromTime <- newTVar ts
+  filesCreated <- newTVar 0
+  fileRecipients <- newTVar 0
+  filesUploaded <- newTVar 0
+  filesExpired <- newTVar 0
+  filesDeleted <- newTVar 0
   filesDownloaded <- newPeriodStats
-  fileDownloads <- newIORef 0
-  fileDownloadAcks <- newIORef 0
-  filesCount <- newIORef 0
-  filesSize <- newIORef 0
+  fileDownloads <- newTVar 0
+  fileDownloadAcks <- newTVar 0
+  filesCount <- newTVar 0
+  filesSize <- newTVar 0
   pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
 
-getFileServerStatsData :: FileServerStats -> IO FileServerStatsData
+getFileServerStatsData :: FileServerStats -> STM FileServerStatsData
 getFileServerStatsData s = do
-  _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
+  _fromTime <- readTVar $ fromTime (s :: FileServerStats)
+  _filesCreated <- readTVar $ filesCreated s
+  _fileRecipients <- readTVar $ fileRecipients s
+  _filesUploaded <- readTVar $ filesUploaded s
+  _filesExpired <- readTVar $ filesExpired s
+  _filesDeleted <- readTVar $ filesDeleted s
   _filesDownloaded <- getPeriodStatsData $ filesDownloaded s
-  _fileDownloads <- readIORef $ fileDownloads s
-  _fileDownloadAcks <- readIORef $ fileDownloadAcks s
-  _filesCount <- readIORef $ filesCount s
-  _filesSize <- readIORef $ filesSize s
+  _fileDownloads <- readTVar $ fileDownloads s
+  _fileDownloadAcks <- readTVar $ fileDownloadAcks s
+  _filesCount <- readTVar $ filesCount s
+  _filesSize <- readTVar $ filesSize s
   pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
 
--- this function is not thread safe, it is used on server start only
-setFileServerStats :: FileServerStats -> FileServerStatsData -> IO ()
+setFileServerStats :: FileServerStats -> FileServerStatsData -> STM ()
 setFileServerStats s d = do
-  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
+  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
   setPeriodStats (filesDownloaded s) $! _filesDownloaded d
-  writeIORef (fileDownloads s) $! _fileDownloads d
-  writeIORef (fileDownloadAcks s) $! _fileDownloadAcks d
-  writeIORef (filesCount s) $! _filesCount d
-  writeIORef (filesSize s) $! _filesSize d
+  writeTVar (fileDownloads s) $! _fileDownloads d
+  writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d
+  writeTVar (filesCount s) $! _filesCount d
+  writeTVar (filesSize s) $! _filesSize d
 
 instance StrEncoding FileServerStatsData where
   strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} =

src/Simplex/FileTransfer/Server/Store.hs

@@ -55,11 +55,11 @@ instance StrEncoding FileRecipient where
   strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey
   strP = FileRecipient <$> strP <* A.char ':' <*> strP
 
-newFileStore :: IO FileStore
+newFileStore :: STM FileStore
 newFileStore = do
-  files <- TM.emptyIO
-  recipients <- TM.emptyIO
-  usedStorage <- newTVarIO 0
+  files <- TM.empty
+  recipients <- TM.empty
+  usedStorage <- newTVar 0
   pure FileStore {files, recipients, usedStorage}
 
 addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ())

src/Simplex/FileTransfer/Types.hs

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

src/Simplex/Messaging/Agent.hs

@@ -33,7 +33,6 @@ module Simplex.Messaging.Agent
     AgentClient (..),
     AE,
     SubscriptionsInfo (..),
-    MsgReq,
     getSMPAgentClient,
     getSMPAgentClient_,
     disconnectAgentClient,
@@ -53,7 +52,6 @@ module Simplex.Messaging.Agent
     deleteConnectionAsync,
     deleteConnectionsAsync,
     createConnection,
-    changeConnectionUser,
     prepareConnectionToJoin,
     joinConnection,
     allowConnection,
@@ -94,7 +92,6 @@ module Simplex.Messaging.Agent
     getNtfTokenData,
     toggleConnectionNtfs,
     xftpStartWorkers,
-    xftpStartSndWorkers,
     xftpReceiveFile,
     xftpDeleteRcvFile,
     xftpDeleteRcvFiles,
@@ -108,7 +105,6 @@ module Simplex.Messaging.Agent
     rcConnectHost,
     rcConnectCtrl,
     rcDiscoverCtrl,
-    getAgentSubsTotal,
     getAgentServersSummary,
     resetAgentServersStats,
     foregroundAgent,
@@ -128,7 +124,7 @@ import Control.Monad.Reader
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
-import Data.Bifunctor (bimap, first, second)
+import Data.Bifunctor (bimap, first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:), (.:.), (.::), (.::.))
@@ -150,7 +146,7 @@ import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
 import Data.Traversable (mapAccumL)
 import Data.Word (Word16)
-import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
+import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
@@ -174,10 +170,10 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId)
-import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), pnMessagesP)
+import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
+import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, 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
@@ -208,7 +204,7 @@ getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp} stor
     runAgent = do
       liftIO $ checkServers "SMP" smp >> checkServers "XFTP" xftp
       currentTs <- liftIO getCurrentTime
-      c@AgentClient {acThread} <- liftIO . newAgentClient clientId initServers currentTs =<< ask
+      c@AgentClient {acThread} <- atomically . newAgentClient clientId initServers currentTs =<< ask
       t <- runAgentThreads c `forkFinally` const (liftIO $ disconnectAgentClient c)
       atomically . writeTVar acThread . Just =<< mkWeakThreadId t
       pure c
@@ -236,30 +232,29 @@ logServersStats c = do
   liftIO $ threadDelay' delay
   int <- asks (logStatsInterval . config)
   forever $ do
-    liftIO $ waitUntilActive c
     saveServersStats c
     liftIO $ threadDelay' int
 
 saveServersStats :: AgentClient -> AM' ()
-saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats, ntfServersStats} = do
-  sss <- mapM (liftIO . getAgentSMPServerStats) =<< readTVarIO smpServersStats
-  xss <- mapM (liftIO . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats
-  nss <- mapM (liftIO . getAgentNtfServerStats) =<< readTVarIO ntfServersStats
-  let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss}
+saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats} = do
+  sss <- mapM (lift . getAgentSMPServerStats) =<< readTVarIO smpServersStats
+  xss <- mapM (lift . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats
+  let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss}
   tryAgentError' (withStore' c (`updateServersStats` stats)) >>= \case
     Left e -> atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e)
     Right () -> pure ()
 
 restoreServersStats :: AgentClient -> AM' ()
-restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, ntfServersStats, srvStatsStartedAt} = do
+restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do
   tryAgentError' (withStore c getServersStats) >>= \case
     Left e -> atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e)
     Right (startedAt, Nothing) -> atomically $ writeTVar srvStatsStartedAt startedAt
-    Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss}) -> do
+    Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss}) -> do
       atomically $ writeTVar srvStatsStartedAt startedAt
-      atomically . writeTVar smpServersStats =<< mapM (atomically . newAgentSMPServerStats') sss
-      atomically . writeTVar xftpServersStats =<< mapM (atomically . newAgentXFTPServerStats') xss
-      atomically . writeTVar ntfServersStats =<< mapM (atomically . newAgentNtfServerStats') nss
+      sss' <- mapM (atomically . newAgentSMPServerStats') sss
+      atomically $ writeTVar smpServersStats sss'
+      xss' <- mapM (atomically . newAgentXFTPServerStats') xss
+      atomically $ writeTVar xftpServersStats xss'
 
 disconnectAgentClient :: AgentClient -> IO ()
 disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do
@@ -334,11 +329,6 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe
 createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs
 {-# INLINE createConnection #-}
 
--- | Changes the user id associated with a connection
-changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
-changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId
-{-# INLINE changeConnectionUser #-}
-
 -- | Create SMP agent connection without queue (to be joined with joinConnection passing connection ID).
 -- This method is required to prevent race condition when confirmation from peer is received before
 -- the caller of joinConnection saves connection ID to the database.
@@ -348,7 +338,7 @@ prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri
 prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs
 
 -- | Join SMP agent connection (JOIN command).
-joinConnection :: AgentClient -> UserId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
+joinConnection :: AgentClient -> UserId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId
 joinConnection c userId Nothing enableNtfs = withAgentEnv c .:: joinConn c userId "" False enableNtfs
 joinConnection c userId (Just connId) enableNtfs = withAgentEnv c .:: joinConn c userId connId True enableNtfs
 {-# INLINE joinConnection #-}
@@ -359,7 +349,7 @@ allowConnection c = withAgentEnv c .:. allowConnection' c
 {-# INLINE allowConnection #-}
 
 -- | Accept contact after REQ notification (ACPT command)
-acceptContact :: AgentClient -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
+acceptContact :: AgentClient -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId
 acceptContact c enableNtfs = withAgentEnv c .:: acceptContact' c "" enableNtfs
 {-# INLINE acceptContact #-}
 
@@ -384,7 +374,7 @@ getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
 {-# INLINE getConnectionMessage #-}
 
 -- | Get connection message for received notification
-getNotificationMessage :: AgentClient -> C.CbNonce -> ByteString -> AE (NotificationInfo, Maybe SMPMsgMeta)
+getNotificationMessage :: AgentClient -> C.CbNonce -> ByteString -> AE (NotificationInfo, [SMPMsgMeta])
 getNotificationMessage c = withAgentEnv c .: getNotificationMessage' c
 {-# INLINE getNotificationMessage #-}
 
@@ -401,10 +391,6 @@ sendMessage :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> A
 sendMessage c = withAgentEnv c .:: sendMessage' c
 {-# INLINE sendMessage #-}
 
--- When sending multiple messages to the same connection,
--- only the first MsgReq for this connection should have non-empty ConnId.
--- All subsequent MsgReq in traversable for this connection must be empty.
--- This is done to optimize processing by grouping all messages to one connection together.
 type MsgReq = (ConnId, PQEncryption, MsgFlags, MsgBody)
 
 -- | Send multiple messages to different connections (SEND command)
@@ -536,10 +522,6 @@ xftpStartWorkers :: AgentClient -> Maybe FilePath -> AE ()
 xftpStartWorkers c = withAgentEnv c . startXFTPWorkers c
 {-# INLINE xftpStartWorkers #-}
 
-xftpStartSndWorkers :: AgentClient -> Maybe FilePath -> AE ()
-xftpStartSndWorkers c = withAgentEnv c . startXFTPSndWorkers c
-{-# INLINE xftpStartSndWorkers #-}
-
 -- | Receive XFTP file
 xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AE RcvFileId
 xftpReceiveFile c = withAgentEnv c .:: xftpReceiveFile' c
@@ -747,16 +729,6 @@ newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe
 newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
   getSMPServer c userId >>= newConnSrv c userId connId False enableNtfs cMode clientData pqInitKeys subMode
 
-changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
-changeConnectionUser' c oldUserId connId newUserId = do
-  SomeConn _ conn <- withStore c (`getConn` connId)
-  case conn of
-    NewConnection {} -> updateConn
-    RcvConnection {} -> updateConn
-    _ -> throwE $ CMD PROHIBITED "changeConnectionUser: established connection"
-  where
-    updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
-
 newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
 newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys subMode srv = do
   connId' <-
@@ -806,7 +778,7 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
           cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
       withStore c $ \db -> createNewConn db g cData SCMInvitation
 
-joinConn :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
+joinConn :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
 joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do
   srv <- case cReq of
     CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
@@ -865,7 +837,7 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
 versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
 {-# INLINE versionPQSupport_ #-}
 
-joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, SndQueueSecured)
+joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM ConnId
 joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
   withInvLock c (strEncode inv) "joinConnSrv" $ do
     (cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup
@@ -882,7 +854,7 @@ joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo p
     -- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key,
     -- similar to how joinConnAsync does that.
     tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
-      Right sqSecured -> pure (connId', sqSecured)
+      Right _ -> pure connId'
       Left e -> do
         -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
         void $ withStore' c $ \db -> deleteConn db Nothing connId'
@@ -891,11 +863,11 @@ 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 connId' qInfo vrsn cReq cInfo
-      pure (connId', False)
+      void $ sendInvitation c userId qInfo vrsn cReq cInfo
+      pure connId'
     Nothing -> throwE $ AGENT A_VERSION
 
-joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
+joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM ()
 joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do
   SomeConn cType conn <- withStore c (`getConn` connId)
   case conn of
@@ -903,7 +875,7 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
     SndConnection _ sq -> doJoin $ Just sq
     _ -> throwE $ CMD PROHIBITED $ "joinConnSrvAsync: bad connection " <> show cType
   where
-    doJoin :: Maybe SndQueue -> AM SndQueueSecured
+    doJoin :: Maybe SndQueue -> AM ()
     doJoin sq_ = do
       (cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport
       sq' <- withStore c $ \db -> runExceptT $ do
@@ -930,14 +902,18 @@ createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVers
 allowConnection' :: AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> AM ()
 allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConnection" $ do
   withStore c (`getConn` connId) >>= \case
-    SomeConn _ (RcvConnection _ RcvQueue {server, rcvId}) -> do
-      AcceptedConfirmation {senderConf = SMPConfirmation {senderKey}} <-
-        withStore c $ \db -> acceptConfirmation db confId ownConnInfo
+    SomeConn _ (RcvConnection _ rq@RcvQueue {server, rcvId, e2ePrivKey, smpClientVersion = v}) -> do
+      senderKey <- withStore c $ \db -> runExceptT $ do
+        AcceptedConfirmation {ratchetState, senderConf = SMPConfirmation {senderKey, e2ePubKey, smpClientVersion = v'}} <- ExceptT $ acceptConfirmation db confId ownConnInfo
+        liftIO $ createRatchet db connId ratchetState
+        let dhSecret = C.dh' e2ePubKey e2ePrivKey
+        liftIO $ setRcvQueueConfirmedE2E db rq dhSecret $ min v v'
+        pure senderKey
       enqueueCommand c "" connId (Just server) . AInternalCommand $ ICAllowSecure rcvId senderKey
     _ -> throwE $ CMD PROHIBITED "allowConnection"
 
 -- | Accept contact (ACPT command) in Reader monad
-acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
+acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
 acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
   Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
   withStore c (`getConn` contactConnId) >>= \case
@@ -974,12 +950,12 @@ subscribeConnections' c connIds = do
   let (errs, cs) = M.mapEither id conns
       errs' = M.map (Left . storeError) errs
       (subRs, rcvQs) = M.mapEither rcvQueueOrResult cs
-  resumeDelivery cs
-  lift $ resumeConnCmds c $ M.keys cs
+  mapM_ (mapM_ (\(cData, sqs) -> mapM_ (lift . resumeMsgDelivery c cData) sqs) . sndQueue) cs
+  mapM_ (resumeConnCmds c) $ M.keys cs
   rcvRs <- lift $ connResults . fst <$> subscribeQueues c (concat $ M.elems rcvQs)
   ns <- asks ntfSupervisor
   tkn <- readTVarIO (ntfTkn ns)
-  lift $ when (instantNotifications tkn) . void . forkIO . void $ sendNtfCreate ns rcvRs cs
+  when (instantNotifications tkn) . void . lift . forkIO . void . runExceptT $ sendNtfCreate ns rcvRs conns
   let rs = M.unions ([errs', subRs, rcvRs] :: [Map ConnId (Either AgentErrorType ())])
   notifyResultError rs
   pure rs
@@ -1011,20 +987,15 @@ subscribeConnections' c connIds = do
         order (Active, _) = 2
         order (_, Right _) = 3
         order _ = 4
-    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId SomeConn -> AM' ()
-    sendNtfCreate ns rcvRs cs = do
-      -- TODO this needs to be batched end to end.
-      -- Currently, the only change is to ignore failed subscriptions.
-      let oks = M.keysSet $ M.filter (either temporaryAgentError $ const True) rcvRs
-      forM_ (M.restrictKeys cs oks) $ \case
-        SomeConn _ conn -> do
-          let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete
-              ConnData {connId} = toConnData conn
-          atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
-    resumeDelivery :: Map ConnId SomeConn -> AM ()
-    resumeDelivery conns = do
-      conns' <- M.restrictKeys conns . S.fromList <$> withStore' c getConnectionsForDelivery
-      lift $ mapM_ (mapM_ (\(cData, sqs) -> mapM_ (resumeMsgDelivery c cData) sqs) . sndQueue) conns'
+    sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId (Either StoreError SomeConn) -> AM ()
+    sendNtfCreate ns rcvRs conns =
+      forM_ (M.assocs rcvRs) $ \case
+        (connId, Right _) -> forM_ (M.lookup connId conns) $ \case
+          Right (SomeConn _ conn) -> do
+            let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete
+            atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
+          _ -> pure ()
+        _ -> pure ()
     sndQueue :: SomeConn -> Maybe (ConnData, NonEmpty SndQueue)
     sndQueue (SomeConn _ conn) = case conn of
       DuplexConnection cData _ sqs -> Just (cData, sqs)
@@ -1060,18 +1031,30 @@ getConnectionMessage' c connId = do
     SndConnection _ _ -> throwE $ CONN SIMPLEX
     NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
 
-getNotificationMessage' :: AgentClient -> C.CbNonce -> ByteString -> AM (NotificationInfo, Maybe SMPMsgMeta)
+getNotificationMessage' :: AgentClient -> C.CbNonce -> ByteString -> AM (NotificationInfo, [SMPMsgMeta])
 getNotificationMessage' c nonce encNtfInfo = do
   withStore' c getActiveNtfToken >>= \case
     Just NtfToken {ntfDhSecret = Just dhSecret} -> do
       ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo
-      pnMsgs <- liftEither (parse pnMessagesP (INTERNAL "error parsing PNMessageData") ntfData)
-      let PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = L.last pnMsgs
+      PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} <- liftEither (parse strP (INTERNAL "error parsing PNMessageData") ntfData)
       (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
       ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
-      msgMeta <- getConnectionMessage' c ntfConnId
-      pure (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta}, msgMeta)
+      maxMsgs <- asks $ ntfMaxMessages . config
+      (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId ntfMsgMeta maxMsgs
     _ -> throwE $ CMD PROHIBITED "getNotificationMessage"
+  where
+    getNtfMessages ntfConnId nMeta = getMsg
+      where
+        getMsg 0 = pure []
+        getMsg n =
+          getConnectionMessage' c ntfConnId >>= \case
+            Just m
+              | lastMsg m -> pure [m]
+              | otherwise -> (m :) <$> getMsg (n - 1)
+            Nothing -> pure []
+        lastMsg SMP.SMPMsgMeta {msgId, msgTs, msgFlags} = case nMeta of
+          Just SMP.NMsgMeta {msgId = msgId', msgTs = msgTs'} -> msgId == msgId' || msgTs > msgTs'
+          Nothing -> SMP.notification msgFlags
 
 -- | Send message to the connection (SEND command) in Reader monad
 sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption)
@@ -1085,88 +1068,78 @@ sendMessages' c = sendMessagesB' c . map Right
 
 sendMessagesB' :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> AM (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
 sendMessagesB' c reqs = do
-  (_, connIds) <- liftEither $ foldl' addConnId (Right ("", S.empty)) reqs
+  connIds <- liftEither $ foldl' addConnId (Right S.empty) reqs
   lift $ sendMessagesB_ c reqs connIds
   where
-    addConnId acc@(Right (prevId, s)) (Right (connId, _, _, _))
-      | B.null connId = if B.null prevId then Left $ INTERNAL "sendMessages: empty first connId" else acc
-      | connId `S.member` s = Left $ INTERNAL "sendMessages: duplicate connId"
-      | otherwise = Right (connId, S.insert connId s)
-    addConnId acc _ = acc
+    addConnId s@(Right s') (Right (connId, _, _, _))
+      | B.null connId = s
+      | connId `S.notMember` s' = Right $ S.insert connId s'
+      | otherwise = Left $ INTERNAL "sendMessages: duplicate connection ID"
+    addConnId s _ = s
 
 sendMessagesB_ :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> Set ConnId -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption)))
 sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
-  prev <- newTVarIO Nothing
-  reqs' <- withStoreBatch c $ \db -> fmap (bindRight $ getConn_ db prev) reqs
+  reqs' <- withStoreBatch c (\db -> fmap (bindRight $ \req@(connId, _, _, _) -> bimap storeError (req,) <$> getConn db connId) reqs)
   let (toEnable, reqs'') = mapAccumL prepareConn [] reqs'
-  void $ withStoreBatch' c $ \db -> map (\connId -> setConnPQSupport db connId PQSupportOn) $ S.toList toEnable
+  void $ withStoreBatch' c $ \db -> map (\connId -> setConnPQSupport db connId PQSupportOn) toEnable
   enqueueMessagesB c reqs''
   where
-    getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (Either AgentErrorType (MsgReq, SomeConn))
-    getConn_ db prev req@(connId, _, _, _) =
-      (req,)
-        <$$> if B.null connId
-          then fromMaybe (Left $ INTERNAL "sendMessagesB_: empty prev connId") <$> readTVarIO prev
-          else do
-            conn <- first storeError <$> getConn db connId
-            conn <$ atomically (writeTVar prev $ Just conn)
-    prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, SomeConn) -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
-    prepareConn s (Left e) = (s, Left e)
-    prepareConn s (Right ((_, pqEnc, msgFlags, msg), SomeConn _ conn)) = case conn of
+    prepareConn :: [ConnId] -> Either AgentErrorType (MsgReq, SomeConn) -> ([ConnId], Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
+    prepareConn acc (Left e) = (acc, Left e)
+    prepareConn acc (Right ((_, pqEnc, msgFlags, msg), SomeConn _ conn)) = case conn of
       DuplexConnection cData _ sqs -> prepareMsg cData sqs
       SndConnection cData sq -> prepareMsg cData [sq]
-      _ -> (s, Left $ CONN SIMPLEX)
+      _ -> (acc, Left $ CONN SIMPLEX)
       where
-        prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
+        prepareMsg :: ConnData -> NonEmpty SndQueue -> ([ConnId], Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
         prepareMsg cData@ConnData {connId, pqSupport} sqs
-          | ratchetSyncSendProhibited cData = (s, Left $ CMD PROHIBITED "sendMessagesB: send prohibited")
+          | ratchetSyncSendProhibited cData = (acc, Left $ CMD PROHIBITED "sendMessagesB: send prohibited")
           -- connection is only updated if PQ encryption was disabled, and now it has to be enabled.
           -- support for PQ encryption (small message envelopes) will not be disabled when message is sent.
           | pqEnc == PQEncOn && pqSupport == PQSupportOff =
               let cData' = cData {pqSupport = PQSupportOn} :: ConnData
-               in (S.insert connId s, mkReq cData')
-          | otherwise = (s, mkReq cData)
-          where
-            mkReq cData' = Right (cData', sqs, Just pqEnc, msgFlags, A_MSG msg)
+               in (connId : acc, Right (cData', sqs, Just pqEnc, msgFlags, A_MSG msg))
+          | otherwise = (acc, Right (cData, sqs, Just pqEnc, msgFlags, A_MSG msg))
 
 -- / async command processing v v v
 
 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 connId server
+  lift . void $ getAsyncCmdWorker True c server
 
-resumeSrvCmds :: AgentClient -> ConnId -> Maybe SMPServer -> AM' ()
-resumeSrvCmds = void .:. getAsyncCmdWorker False
+resumeSrvCmds :: AgentClient -> Maybe SMPServer -> AM' ()
+resumeSrvCmds = void .: getAsyncCmdWorker False
 {-# INLINE resumeSrvCmds #-}
 
-resumeConnCmds :: AgentClient -> [ConnId] -> AM' ()
-resumeConnCmds c connIds = do
-  connSrvs <- rights . zipWith (second . (,)) connIds <$> withStoreBatch' c (\db -> fmap (getPendingCommandServers db) connIds)
-  mapM_ (\(connId, srvs) -> mapM_ (resumeSrvCmds c connId) srvs) connSrvs
+resumeConnCmds :: AgentClient -> ConnId -> AM ()
+resumeConnCmds c connId =
+  unlessM connQueued $
+    withStore' c (`getPendingCommandServers` connId)
+      >>= mapM_ (lift . resumeSrvCmds c)
+  where
+    connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
 
-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)
+getAsyncCmdWorker :: Bool -> AgentClient -> Maybe SMPServer -> AM' Worker
+getAsyncCmdWorker hasWork c server =
+  getAgentWorker "async_cmd" hasWork c server (asyncCmdWorkers c) (runCommandProcessing c server)
 
-data CommandCompletion = CCMoved | CCCompleted
-
-runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM ()
-runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
+runCommandProcessing :: AgentClient -> Maybe SMPServer -> Worker -> AM ()
+runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
   ri <- asks $ messageRetryInterval . config -- different retry interval?
   forever $ do
     atomically $ endAgentOperation c AOSndNetwork
     lift $ waitForWork doWork
-    liftIO $ throwWhenInactive c
+    atomically $ throwWhenInactive c
     atomically $ beginAgentOperation c AOSndNetwork
-    withWork c doWork (\db -> getPendingServerCommand db connId server_) $ runProcessCmd (riFast ri)
+    withWork c doWork (`getPendingServerCommand` 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, command} pendingCmds = case command of
+    processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} pendingCmds = case command of
       AClientCommand cmd -> case cmd of
         NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
           usedSrvs <- newTVarIO ([] :: [SMPServer])
@@ -1177,8 +1150,8 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
           let initUsed = [qServer q]
           usedSrvs <- newTVarIO initUsed
           tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do
-            sqSecured <- joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
-            notify $ JOINED sqSecured
+            joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
+            notify OK
         LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
         ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK
         SWCH ->
@@ -1192,27 +1165,16 @@ runCommandProcessing c@AgentClient {subQ} connId 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' . tryMoveableWithLock "ICAllowSecure" $ do
+        ICAllowSecure _rId senderKey -> withServer' . tryWithLock "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 :| _) -> 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
+            DuplexConnection cData _ (sq :| _) ->
+              mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf)
             _ -> throwE $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd)
         ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do
           secure rq senderKey
@@ -1285,18 +1247,13 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
           withStore c (`getConn` connId) >>= \case
             SomeConn _ conn@DuplexConnection {} -> a conn
             _ -> internalErr "command requires duplex connection"
-        tryCommand action = tryMoveableCommand (action $> CCCompleted)
-        tryMoveableCommand action = withRetryInterval ri $ \_ loop -> do
-          liftIO $ waitWhileSuspended c
-          liftIO $ waitForUserNetwork c
-          tryAgentError action >>= \case
+        tryCommand action = withRetryInterval ri $ \_ loop ->
+          tryError action >>= \case
             Left e
               | temporaryOrHostError e -> retrySndOp c loop
               | otherwise -> cmdError e
-            Right CCCompleted -> withStore' c (`deleteCommand` cmdId)
-            Right CCMoved -> pure () -- command processing moved to another command queue
+            Right () -> withStore' c (`deleteCommand` cmdId)
         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 ()
@@ -1344,7 +1301,7 @@ enqueueMessageB c reqs = do
     storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
       let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg
       internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
+      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
           agentMsg = AgentMessage privHeader aMessage
           agentMsgStr = smpEncode agentMsg
@@ -1398,8 +1355,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI
   forever $ do
     atomically $ endAgentOperation c AOSndNetwork
     lift $ waitForWork doWork
-    liftIO $ throwWhenInactive c
-    liftIO $ throwWhenNoDelivery c sq
+    atomically $ throwWhenInactive c
+    atomically $ throwWhenNoDelivery c sq
     atomically $ beginAgentOperation c AOSndNetwork
     withWork c doWork (\db -> getPendingQueueMsg db connId sq) $
       \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs}) -> do
@@ -1407,7 +1364,6 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI
         let mId = unId msgId
             ri' = maybe id updateRetryInterval2 msgRetryState ri
         withRetryLock2 ri' qLock $ \riState loop -> do
-          liftIO $ waitWhileSuspended c
           liftIO $ waitForUserNetwork c
           resp <- tryError $ case msgType of
             AM_CONN_INFO -> sendConfirmation c sq msgBody
@@ -1560,7 +1516,7 @@ retrySndOp :: AgentClient -> AM () -> AM ()
 retrySndOp c loop = do
   -- end... is in a separate atomically because if begin... blocks, SUSPENDED won't be sent
   atomically $ endAgentOperation c AOSndNetwork
-  liftIO $ throwWhenInactive c
+  atomically $ throwWhenInactive c
   atomically $ beginAgentOperation c AOSndNetwork
   loop
 
@@ -2065,7 +2021,7 @@ deleteNtfSubs c deleteCmd = do
 sendNtfConnCommands :: AgentClient -> NtfSupervisorCommand -> AM ()
 sendNtfConnCommands c cmd = do
   ns <- asks ntfSupervisor
-  connIds <- liftIO $ getSubscriptions c
+  connIds <- atomically $ getSubscriptions c
   forM_ connIds $ \connId -> do
     withStore' c (`getConnData` connId) >>= \case
       Just (ConnData {enableNtfs}, _) ->
@@ -2147,7 +2103,7 @@ cleanupManager c@AgentClient {subQ} = do
   liftIO $ threadDelay' delay
   int <- asks (cleanupInterval . config)
   ttl <- asks $ storedMsgDataTTL . config
-  forever $ waitActive $ do
+  forever $ do
     run ERR deleteConns
     run ERR $ withStore' c (`deleteRcvMsgHashesExpired` ttl)
     run ERR $ withStore' c (`deleteSndMsgsExpired` ttl)
@@ -2167,8 +2123,7 @@ cleanupManager c@AgentClient {subQ} = do
       step <- asks $ cleanupStepInterval . config
       liftIO $ threadDelay step
     -- we are catching it to avoid CRITICAL errors in tests when this is the only remaining handle to active
-    waitActive :: ReaderT Env IO a -> AM' ()
-    waitActive a = liftIO (E.tryAny $ waitUntilActive c) >>= either (\_ -> pure ()) (\_ -> void a)
+    waitActive a = liftIO (E.tryAny . atomically $ waitUntilActive c) >>= either (\_ -> pure ()) (\_ -> void a)
     deleteConns =
       withLock (deleteLock c) "cleanupManager" $ do
         void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
@@ -2209,7 +2164,7 @@ cleanupManager c@AgentClient {subQ} = do
     deleteExpiredReplicasForDeletion = do
       rcvFilesTTL <- asks $ rcvFilesTTL . config
       withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL)
-    notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM ()
+    notify :: forall e. AEntityI e => EntityId -> AEvent e -> AM ()
     notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd)
 
 data ACKd = ACKd | ACKPending
@@ -2258,7 +2213,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
     processSubOk :: RcvQueue -> TVar [ConnId] -> AM ()
     processSubOk rq@RcvQueue {connId} upConnIds =
       atomically . whenM (isPendingSub connId) $ do
-        addSubscription c sessId rq
+        addSubscription c rq
         modifyTVar' upConnIds (connId :)
     processSubErr :: RcvQueue -> SMPClientError -> AM ()
     processSubErr rq@RcvQueue {connId} e = do
@@ -2293,7 +2248,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
               ack' <- handleNotifyAck $ case msg' of
                 SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
                 SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
-              whenM (liftIO $ hasGetLock c rq) $
+              whenM (atomically $ hasGetLock c rq) $
                 notify (MSGNTF $ SMP.rcvMessageMeta srvMsgId msg')
               pure ack'
             where
@@ -2346,7 +2301,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
@@ -2356,7 +2311,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
@@ -2379,7 +2334,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
@@ -2501,7 +2456,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
@@ -2532,18 +2487,6 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
                           confId <- withStore c $ \db -> do
                             setConnAgentVersion db connId agentVersion
                             when (pqSupport /= pqSupport') $ setConnPQSupport db connId pqSupport'
-                            -- /
-                            -- Starting with agent version 7 (ratchetOnConfSMPAgentVersion),
-                            -- initiating party initializes ratchet on processing confirmation;
-                            -- previously, it initialized ratchet on allowConnection;
-                            -- this is to support decryption of messages that may be received before allowConnection
-                            liftIO $ do
-                              createRatchet db connId rc'
-                              let RcvQueue {smpClientVersion = v, e2ePrivKey = e2ePrivKey'} = rq
-                                  SMPConfirmation {smpClientVersion = v', e2ePubKey = e2ePubKey'} = senderConf
-                                  dhSecret = C.dh' e2ePubKey' e2ePrivKey'
-                              setRcvQueueConfirmedE2E db rq dhSecret $ min v v'
-                            -- /
                             createConfirmation db g newConfirmation
                           let srvs = map qServer $ smpReplyQueues senderConf
                           notify $ CONF confId pqSupport' srvs connInfo
@@ -2570,7 +2513,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"
               _ ->
@@ -2594,7 +2537,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 ())
@@ -2603,7 +2546,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
@@ -2643,7 +2586,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
@@ -2664,7 +2607,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
@@ -2685,7 +2628,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
@@ -2709,7 +2652,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.
@@ -2827,50 +2770,42 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _
     Just qInfo' -> do
       -- in case of SKEY retry the connection is already duplex
       sq' <- maybe upgradeConn pure sq_
-      void $ agentSecureSndQueue c cData sq'
+      agentSecureSndQueue c sq'
       enqueueConfirmation c cData sq' ownConnInfo Nothing
       where
         upgradeConn = do
           (sq, _) <- lift $ newSndQueue userId connId qInfo'
           withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
 
-secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM SndQueueSecured
+secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM ()
 secureConfirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do
-  sqSecured <- agentSecureSndQueue c cData sq
+  agentSecureSndQueue c sq
   storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation c cData sq srv connInfo subMode
   lift $ submitPendingMsg c cData sq
-  pure sqSecured
 
-secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM SndQueueSecured
+secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM ()
 secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do
-  sqSecured <- agentSecureSndQueue c cData sq
+  agentSecureSndQueue c sq
   msg <- mkConfirmation =<< mkAgentConfirmation c cData sq srv connInfo subMode
   void $ sendConfirmation c sq msg
   withStore' c $ \db -> setSndQueueStatus db sq Confirmed
-  pure sqSecured
   where
     mkConfirmation :: AgentMessage -> AM MsgBody
     mkConfirmation aMessage = do
       currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
       withStore c $ \db -> runExceptT $ do
         let agentMsgBody = smpEncode aMessage
-        (_, internalSndId, _) <- ExceptT $ updateSndIds db connId
+        (_, internalSndId, _) <- liftIO $ updateSndIds db connId
         liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody)
         let pqEnc = CR.pqSupportToEnc pqSupport
         (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion
         pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo}
 
-agentSecureSndQueue :: AgentClient -> ConnData -> SndQueue -> AM SndQueueSecured
-agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {sndSecure, status}
-  | sndSecure && status == New = do
-      secureSndQueue c sq
-      withStore' c $ \db -> setSndQueueStatus db sq Secured
-      pure initiatorRatchetOnConf
-  -- on repeat JOIN processing (e.g. previous attempt to create reply queue failed)
-  | sndSecure && status == Secured = pure initiatorRatchetOnConf
-  | otherwise = pure False
-  where
-    initiatorRatchetOnConf = connAgentVersion >= ratchetOnConfSMPAgentVersion
+agentSecureSndQueue :: AgentClient -> SndQueue -> AM ()
+agentSecureSndQueue c sq@SndQueue {sndSecure, status} =
+  when (sndSecure && status == New) $ do
+    secureSndQueue c sq
+    withStore' c $ \db -> setSndQueueStatus db sq Secured
 
 mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM AgentMessage
 mkAgentConfirmation c cData sq srv connInfo subMode = do
@@ -2887,7 +2822,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq
   currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
   withStore c $ \db -> runExceptT $ do
     internalTs <- liftIO getCurrentTime
-    (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
+    (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
     let agentMsgStr = smpEncode agentMsg
         internalHash = C.sha256Hash agentMsgStr
         pqEnc = CR.pqSupportToEnc pqSupport
@@ -2913,7 +2848,7 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
     storeRatchetKey :: VersionSMPA -> AM InternalId
     storeRatchetKey agentVersion = withStore c $ \db -> runExceptT $ do
       internalTs <- liftIO getCurrentTime
-      (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
+      (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
       let agentMsg = AgentRatchetInfo ""
           agentMsgStr = smpEncode agentMsg
           internalHash = C.sha256Hash agentMsgStr

src/Simplex/Messaging/Agent/Client.hs

@@ -12,7 +12,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
@@ -83,7 +82,6 @@ module Simplex.Messaging.Agent.Client
     deleteQueues,
     logServer,
     logSecret,
-    logSecret',
     removeSubscription,
     hasActiveSubscription,
     hasPendingSubscription,
@@ -95,7 +93,6 @@ module Simplex.Messaging.Agent.Client
     AgentServersSummary (..),
     ServerSessions (..),
     SMPServerSubs (..),
-    getAgentSubsTotal,
     getAgentServersSummary,
     getAgentSubscriptions,
     slowNetworkConfig,
@@ -120,7 +117,7 @@ module Simplex.Messaging.Agent.Client
     waitUntilActive,
     UserNetworkInfo (..),
     UserNetworkType (..),
-    getFastNetworkConfig,
+    getNetworkConfig',
     waitForUserNetwork,
     isNetworkOnline,
     isOnline,
@@ -129,7 +126,6 @@ module Simplex.Messaging.Agent.Client
     beginAgentOperation,
     endAgentOperation,
     waitUntilForeground,
-    waitWhileSuspended,
     suspendSendingAndDatabase,
     suspendOperation,
     notifySuspended,
@@ -149,7 +145,6 @@ module Simplex.Messaging.Agent.Client
     incXFTPServerStat,
     incXFTPServerStat',
     incXFTPServerSizeStat,
-    incNtfServerStat,
     AgentWorkersDetails (..),
     getAgentWorkersDetails,
     AgentWorkersSummary (..),
@@ -165,9 +160,9 @@ module Simplex.Messaging.Agent.Client
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent (ThreadId, killThread)
+import Control.Concurrent (ThreadId, forkIO)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
-import Control.Concurrent.STM (retry)
+import Control.Concurrent.STM (retry, throwSTM)
 import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
 import Control.Logger.Simple
 import Control.Monad
@@ -230,7 +225,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumT
 import Simplex.Messaging.Protocol
   ( AProtocolType (..),
     BrokerMsg,
-    EntityId (..),
+    EntityId,
     ErrorType,
     MsgFlags (..),
     MsgId,
@@ -243,6 +238,7 @@ import Simplex.Messaging.Protocol
     ProtocolServer (..),
     ProtocolType (..),
     ProtocolTypeI (..),
+    QueueId,
     QueueIdsKeys (..),
     RcvMessage (..),
     RcvNtfPublicDhKey,
@@ -256,7 +252,6 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
     XFTPServer,
     XFTPServerWithAuth,
-    pattern NoEntity,
     sameSrvAddr',
   )
 import qualified Simplex.Messaging.Protocol as SMP
@@ -268,11 +263,10 @@ import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessio
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
-import System.Mem.Weak (Weak, deRefWeak)
+import System.Mem.Weak (Weak)
 import System.Random (randomR)
 import UnliftIO (mapConcurrently, timeout)
 import UnliftIO.Async (async)
-import UnliftIO.Concurrent (forkIO, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -310,12 +304,13 @@ data AgentClient = AgentClient
     userNetworkInfo :: TVar UserNetworkInfo,
     userNetworkUpdated :: TVar (Maybe UTCTime),
     subscrConns :: TVar (Set ConnId),
-    activeSubs :: TRcvQueues (SessionId, RcvQueue),
-    pendingSubs :: TRcvQueues RcvQueue,
+    activeSubs :: TRcvQueues,
+    pendingSubs :: TRcvQueues,
     removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
     workerSeq :: TVar Int,
     smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
-    asyncCmdWorkers :: TMap (ConnId, Maybe SMPServer) Worker,
+    asyncCmdWorkers :: TMap (Maybe SMPServer) Worker,
+    connCmdsQueued :: TMap ConnId Bool,
     ntfNetworkOp :: TVar AgentOpState,
     rcvNetworkOp :: TVar AgentOpState,
     msgDeliveryOp :: TVar AgentOpState,
@@ -335,7 +330,6 @@ data AgentClient = AgentClient
     agentEnv :: Env,
     smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats,
     xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats,
-    ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats,
     srvStatsStartedAt :: TVar UTCTime
   }
 
@@ -374,15 +368,13 @@ getAgentWorker' toW fromW name hasWork c key ws work = do
           restart <- atomically $ getWorker >>= maybe (pure False) (shouldRestart e_ (toW w) t maxRestarts)
           when restart runWork
         shouldRestart e_ Worker {workerId = wId, doWork, action, restarts} t maxRestarts w'
-          | wId == workerId (toW w') = do
-              rc <- readTVar restarts
-              isActive <- readTVar $ active c
-              checkRestarts isActive $ updateRestartCount t rc
+          | wId == workerId (toW w') =
+              checkRestarts . updateRestartCount t =<< readTVar restarts
           | otherwise =
               pure False -- there is a new worker in the map, no action
           where
-            checkRestarts isActive rc
-              | isActive && restartCount rc < maxRestarts = do
+            checkRestarts rc
+              | restartCount rc < maxRestarts = do
                   writeTVar restarts rc
                   hasWorkToDo' doWork
                   void $ tryPutTMVar action Nothing
@@ -390,7 +382,7 @@ getAgentWorker' toW fromW name hasWork c key ws work = do
                   pure True
               | otherwise = do
                   TM.delete key ws
-                  when isActive $ notifyErr $ CRITICAL True
+                  notifyErr $ CRITICAL True
                   pure False
               where
                 notifyErr err = do
@@ -413,7 +405,7 @@ runWorkerAsync Worker {action} work =
     (atomically . tryPutTMVar action) -- if it was running (or if start crashes), put it back and unlock (don't lock if it was just started)
     (\a -> when (isNothing a) start) -- start worker if it's not running
   where
-    start = atomically . putTMVar action . Just =<< mkWeakThreadId =<< forkIO work
+    start = atomically . putTMVar action . Just =<< async work
 
 data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
   deriving (Eq, Show)
@@ -457,46 +449,46 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
   deriving (Eq, Show)
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
-newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> IO AgentClient
+newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> STM AgentClient
 newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do
   let cfg = config agentEnv
       qSize = tbqSize cfg
-  acThread <- newTVarIO Nothing
-  active <- newTVarIO True
-  subQ <- newTBQueueIO qSize
-  msgQ <- newTBQueueIO qSize
-  smpServers <- newTVarIO $ M.map mkUserServers smp
-  smpClients <- TM.emptyIO
-  smpProxiedRelays <- TM.emptyIO
-  ntfServers <- newTVarIO ntf
-  ntfClients <- TM.emptyIO
-  xftpServers <- newTVarIO $ M.map mkUserServers xftp
-  xftpClients <- TM.emptyIO
-  useNetworkConfig <- newTVarIO (slowNetworkConfig netCfg, netCfg)
-  userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True
-  userNetworkUpdated <- newTVarIO Nothing
-  subscrConns <- newTVarIO S.empty
+  acThread <- newTVar Nothing
+  active <- newTVar True
+  subQ <- newTBQueue qSize
+  msgQ <- newTBQueue qSize
+  smpServers <- newTVar $ M.map mkUserServers smp
+  smpClients <- TM.empty
+  smpProxiedRelays <- TM.empty
+  ntfServers <- newTVar ntf
+  ntfClients <- TM.empty
+  xftpServers <- newTVar $ M.map mkUserServers xftp
+  xftpClients <- TM.empty
+  useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg)
+  userNetworkInfo <- newTVar $ UserNetworkInfo UNOther True
+  userNetworkUpdated <- newTVar Nothing
+  subscrConns <- newTVar S.empty
   activeSubs <- RQ.empty
   pendingSubs <- RQ.empty
-  removedSubs <- TM.emptyIO
-  workerSeq <- newTVarIO 0
-  smpDeliveryWorkers <- TM.emptyIO
-  asyncCmdWorkers <- TM.emptyIO
-  ntfNetworkOp <- newTVarIO $ AgentOpState False 0
-  rcvNetworkOp <- newTVarIO $ AgentOpState False 0
-  msgDeliveryOp <- newTVarIO $ AgentOpState False 0
-  sndNetworkOp <- newTVarIO $ AgentOpState False 0
-  databaseOp <- newTVarIO $ AgentOpState False 0
-  agentState <- newTVarIO ASForeground
-  getMsgLocks <- TM.emptyIO
-  connLocks <- TM.emptyIO
-  invLocks <- TM.emptyIO
-  deleteLock <- atomically createLock
-  smpSubWorkers <- TM.emptyIO
-  smpServersStats <- TM.emptyIO
-  xftpServersStats <- TM.emptyIO
-  ntfServersStats <- TM.emptyIO
-  srvStatsStartedAt <- newTVarIO currentTs
+  removedSubs <- TM.empty
+  workerSeq <- newTVar 0
+  smpDeliveryWorkers <- TM.empty
+  asyncCmdWorkers <- TM.empty
+  connCmdsQueued <- TM.empty
+  ntfNetworkOp <- newTVar $ AgentOpState False 0
+  rcvNetworkOp <- newTVar $ AgentOpState False 0
+  msgDeliveryOp <- newTVar $ AgentOpState False 0
+  sndNetworkOp <- newTVar $ AgentOpState False 0
+  databaseOp <- newTVar $ AgentOpState False 0
+  agentState <- newTVar ASForeground
+  getMsgLocks <- TM.empty
+  connLocks <- TM.empty
+  invLocks <- TM.empty
+  deleteLock <- createLock
+  smpSubWorkers <- TM.empty
+  smpServersStats <- TM.empty
+  xftpServersStats <- TM.empty
+  srvStatsStartedAt <- newTVar currentTs
   return
     AgentClient
       { acThread,
@@ -520,6 +512,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
         workerSeq,
         smpDeliveryWorkers,
         asyncCmdWorkers,
+        connCmdsQueued,
         ntfNetworkOp,
         rcvNetworkOp,
         msgDeliveryOp,
@@ -535,7 +528,6 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
         agentEnv,
         smpServersStats,
         xftpServersStats,
-        ntfServersStats,
         srvStatsStartedAt
       }
 
@@ -602,7 +594,7 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
     >>= either newClient (waitForProtocolClient c tSess smpClients)
   where
     newClient v = do
-      prs <- liftIO TM.emptyIO
+      prs <- atomically TM.empty
       smpConnectClient c tSess prs v
 
 getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
@@ -620,10 +612,11 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
       (tSess,auth,) <$> getSessVar workerSeq tSess smpClients ts
     newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
     newProxyClient tSess auth ts v = do
-      prs <- liftIO TM.emptyIO
-      -- we do not need to check if it is a new proxied relay session,
-      -- as the client is just created and there are no sessions yet
-      rv <- atomically $ either id id <$> getSessVar workerSeq destSrv prs ts
+      (prs, rv) <- atomically $ do
+        prs <- TM.empty
+        -- we do not need to check if it is a new proxied relay session,
+        -- as the client is just created and there are no sessions yet
+        (prs,) . either id id <$> getSessVar workerSeq destSrv prs ts
       clnt <- smpConnectClient c tSess prs v
       (clnt,) <$> newProxiedRelay clnt auth rv
     waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
@@ -649,7 +642,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
             pure $ Left e
     waitForProxiedRelay :: SMPTransportSession -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
     waitForProxiedRelay (_, srv, _) rv = do
-      NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
+      NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c
       sess_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar rv)
       pure $ case sess_ of
         Just (Right sess) -> Right sess
@@ -679,13 +672,11 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess
     -- because we can have a race condition when a new current client could have already
     -- made subscriptions active, and the old client would be processing diconnection later.
     removeClientAndSubs :: IO ([RcvQueue], [ConnId])
-    removeClientAndSubs = atomically $ do
-      removeSessVar v tSess smpClients
-      ifM (readTVar active) removeSubs (pure ([], []))
+    removeClientAndSubs = atomically $ ifM currentActiveClient removeSubs $ pure ([], [])
       where
-        sessId = sessionId $ thParams client
+        currentActiveClient = (&&) <$> removeSessVar' v tSess smpClients <*> readTVar active
         removeSubs = do
-          (qs, cs) <- RQ.getDelSessQueues tSess sessId $ activeSubs c
+          (qs, cs) <- RQ.getDelSessQueues tSess $ activeSubs c
           RQ.batchAddQueues (pendingSubs c) qs
           -- this removes proxied relays that this client created sessions to
           destSrvs <- M.keys <$> readTVar prs
@@ -710,7 +701,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
   where
     getWorkerVar ts =
       ifM
-        (not <$> RQ.hasSessQueues tSess (pendingSubs c))
+        (null <$> getPending)
         (pure Nothing) -- prevent race with cleanup and adding pending queues in another call
         (Just <$> getSessVar workerSeq tSess smpSubWorkers ts)
     newSubWorker v = do
@@ -718,14 +709,13 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
       atomically $ putTMVar (sessionVar v) a
     runSubWorker = do
       ri <- asks $ reconnectInterval . config
-      withRetryForeground ri isForeground (isNetworkOnline c) $ \_ loop -> do
-        pending <- liftIO $ RQ.getSessQueues tSess $ pendingSubs c
+      withRetryInterval ri $ \_ loop -> do
+        pending <- atomically getPending
         forM_ (L.nonEmpty pending) $ \qs -> do
-          liftIO $ waitUntilForeground c
           liftIO $ waitForUserNetwork c
           reconnectSMPClient c tSess qs
           loop
-    isForeground = (ASForeground ==) <$> readTVar (agentState c)
+    getPending = RQ.getSessQueues tSess $ pendingSubs c
     cleanup :: SessionVar (Async ()) -> STM ()
     cleanup v = do
       -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
@@ -790,7 +780,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv
     connectClient :: XFTPClientVar -> AM XFTPClient
     connectClient v = do
       cfg <- asks $ xftpCfg . config
-      xftpNetworkConfig <- getNetworkConfig c
+      xftpNetworkConfig <- atomically $ getNetworkConfig c
       liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
         X.getXFTPClient tSess cfg {xftpNetworkConfig} $
           clientDisconnected v
@@ -809,7 +799,7 @@ waitForProtocolClient ::
   ClientVar msg ->
   AM (Client msg)
 waitForProtocolClient c tSess@(_, srv, _) clients v = do
-  NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
+  NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c
   client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
   case client_ of
     Just (Right smpClient) -> pure smpClient
@@ -860,26 +850,26 @@ hostEvent' event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clie
 getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
 getClientConfig c cfgSel = do
   cfg <- asks $ cfgSel . config
-  networkConfig <- getNetworkConfig c
+  networkConfig <- atomically $ getNetworkConfig c
   pure cfg {networkConfig}
 
-getNetworkConfig :: MonadIO m => AgentClient -> m NetworkConfig
+getNetworkConfig :: AgentClient -> STM NetworkConfig
 getNetworkConfig c = do
-  (slowCfg, fastCfg) <- readTVarIO $ useNetworkConfig c
-  UserNetworkInfo {networkType} <- readTVarIO $ userNetworkInfo c
+  (slowCfg, fastCfg) <- readTVar (useNetworkConfig c)
+  UserNetworkInfo {networkType} <- readTVar $ userNetworkInfo c
   pure $ case networkType of
     UNCellular -> slowCfg
     UNNone -> slowCfg
     _ -> fastCfg
 
 -- returns fast network config
-getFastNetworkConfig :: AgentClient -> IO NetworkConfig
-getFastNetworkConfig = fmap snd . readTVarIO . useNetworkConfig
-{-# INLINE getFastNetworkConfig #-}
+getNetworkConfig' :: AgentClient -> IO NetworkConfig
+getNetworkConfig' = fmap snd . readTVarIO . useNetworkConfig
+{-# INLINE getNetworkConfig' #-}
 
 waitForUserNetwork :: AgentClient -> IO ()
 waitForUserNetwork c =
-  unlessM (isOnline <$> readTVarIO (userNetworkInfo c)) $ do
+  unlessM (atomically $ isNetworkOnline c) $ do
     delay <- registerDelay $ userNetworkInterval $ config $ agentEnv c
     atomically $ unlessM (isNetworkOnline c) $ unlessM (readTVar delay) retry
 
@@ -893,6 +883,7 @@ closeAgentClient c = do
   atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect
   clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst)
   clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker
+  clear connCmdsQueued
   atomically . RQ.clear $ activeSubs c
   atomically . RQ.clear $ pendingSubs c
   clear subscrConns
@@ -908,20 +899,21 @@ closeAgentClient c = do
 cancelWorker :: Worker -> IO ()
 cancelWorker Worker {doWork, action} = do
   noWorkToDo doWork
-  atomically (tryTakeTMVar action) >>= mapM_ (mapM_ $ deRefWeak >=> mapM_ killThread)
+  atomically (tryTakeTMVar action) >>= mapM_ (mapM_ uninterruptibleCancel)
 
-waitUntilActive :: AgentClient -> IO ()
-waitUntilActive AgentClient {active} = unlessM (readTVarIO active) $ atomically $ unlessM (readTVar active) retry
+waitUntilActive :: AgentClient -> STM ()
+waitUntilActive c = unlessM (readTVar $ active c) retry
+{-# INLINE waitUntilActive #-}
 
-throwWhenInactive :: AgentClient -> IO ()
-throwWhenInactive c = unlessM (readTVarIO $ active c) $ E.throwIO ThreadKilled
+throwWhenInactive :: AgentClient -> STM ()
+throwWhenInactive c = unlessM (readTVar $ active c) $ throwSTM ThreadKilled
 {-# INLINE throwWhenInactive #-}
 
 -- this function is used to remove workers once delivery is complete, not when it is removed from the map
-throwWhenNoDelivery :: AgentClient -> SndQueue -> IO ()
+throwWhenNoDelivery :: AgentClient -> SndQueue -> STM ()
 throwWhenNoDelivery c sq =
-  unlessM (TM.memberIO (qAddress sq) $ smpDeliveryWorkers c) $
-    E.throwIO ThreadKilled
+  unlessM (TM.member (qAddress sq) $ smpDeliveryWorkers c) $
+    throwSTM ThreadKilled
 
 closeProtocolServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
@@ -947,7 +939,7 @@ closeClient c clientSel tSess =
 
 closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO ()
 closeClient_ c v = do
-  NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
+  NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c
   E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $
     tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
       Just (Right client) -> closeProtocolServerClient (protocolClient client) `catchAll_` pure ()
@@ -998,7 +990,7 @@ withClient_ c tSess@(_, srv, _) action = do
   where
     logServerError :: AgentErrorType -> AM a
     logServerError e = do
-      logServer "<--" c srv NoEntity $ bshow e
+      logServer "<--" c srv "" $ bshow e
       throwE e
 
 withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
@@ -1015,32 +1007,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 NoEntity $ bshow e
+      logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e
       throwE e
 
-withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
+withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> 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 -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
+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 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 (unEntityId $ queueId q) cmdStr $ action . connectedClient
+  tSess <- liftIO $ mkSMPTransportSession c q
+  withLogClient c tSess (queueId q) cmdStr $ action . connectedClient
 
-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
+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
   where
     sendViaProxy smp proxySess = do
       atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
@@ -1054,15 +1046,14 @@ 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 connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
-  tSess <- mkTransportSession c userId destSrv connId
-  ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
+sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
+  sess <- liftIO $ mkTransportSession c userId destSrv senderId
+  ifM (atomically shouldUseProxy) (sendViaProxy Nothing sess) (sendDirectly sess $> Nothing)
   where
     shouldUseProxy = do
       cfg <- getNetworkConfig c
@@ -1079,9 +1070,9 @@ sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy se
         SPFAllow -> True
         SPFAllowProtected -> ipAddressProtected cfg destSrv
         SPFProhibit -> False
-    unknownServer = liftIO $ maybe True (notElem destSrv . knownSrvs) <$> TM.lookupIO userId (smpServers c)
+    unknownServer = maybe True (notElem destSrv . knownSrvs) <$> TM.lookup userId (smpServers c)
     sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
-    sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
+    sendViaProxy proxySrv_ destSess@(_, _, qId) = do
       r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
         r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
         let proxySrv = protocolClientServer' smp
@@ -1108,7 +1099,7 @@ sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy se
               -- 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, connId_) (smpClients c)
+                    $>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, qId) (smpClients c)
                 )
                   >>= \case
                     Just (Right (SMPConnectedClient smp' prs))
@@ -1125,10 +1116,10 @@ sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy se
           forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
           pure r'
         Left e
-          | serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e)
+          | serverHostError e -> ifM (atomically directAllowed) (sendDirectly destSess $> Nothing) (throwE e)
           | otherwise -> throwE e
     sendDirectly tSess =
-      withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
+      withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
         r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp
         case r of
           Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect
@@ -1141,18 +1132,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 (EntityId entId) = withLogClient c (0, srv, Nothing) entId
+withNtfClient c srv = withLogClient c (0, srv, Nothing)
 
 withXFTPClient ::
   ProtocolServerClient v err msg =>
   AgentClient ->
-  (UserId, ProtoServer msg, ByteString) ->
+  (UserId, ProtoServer msg, EntityId) ->
   ByteString ->
   (Client msg -> ExceptT (ProtocolClientError err) IO b) ->
   AM b
-withXFTPClient c (userId, srv, sessEntId) cmdStr action = do
-  tSess <- mkTransportSession c userId srv sessEntId
-  withLogClient c tSess sessEntId cmdStr action
+withXFTPClient c (userId, srv, entityId) cmdStr action = do
+  tSess <- liftIO $ mkTransportSession c userId srv entityId
+  withLogClient c tSess entityId cmdStr action
 
 liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a
 liftClient protocolError_ = liftError . protocolClientError protocolError_
@@ -1223,7 +1214,7 @@ runXFTPServerTest :: AgentClient -> UserId -> XFTPServerWithAuth -> AM' (Maybe P
 runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
   cfg <- asks $ xftpCfg . config
   g <- asks random
-  xftpNetworkConfig <- getNetworkConfig c
+  xftpNetworkConfig <- atomically $ getNetworkConfig c
   workDir <- getXFTPWorkPath
   filePath <- getTempFilePath workDir
   rcvPath <- getTempFilePath workDir
@@ -1294,15 +1285,15 @@ getXFTPWorkPath = do
   workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
   maybe getTemporaryDirectory pure workDir
 
-mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> ByteString -> m (TransportSession msg)
-mkTransportSession c userId srv sessEntId = mkTSession userId srv sessEntId <$> getSessionMode c
+mkTransportSession :: AgentClient -> UserId -> ProtoServer msg -> EntityId -> IO (TransportSession msg)
+mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c
 {-# INLINE mkTransportSession #-}
 
-mkTSession :: UserId -> ProtoServer msg -> ByteString -> TransportSessionMode -> TransportSession msg
-mkTSession userId srv sessEntId mode = (userId, srv, if mode == TSMEntity then Just sessEntId else Nothing)
+mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg
+mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing)
 {-# INLINE mkTSession #-}
 
-mkSMPTransportSession :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession
+mkSMPTransportSession :: SMPQueueRec q => AgentClient -> q -> IO SMPTransportSession
 mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c
 {-# INLINE mkSMPTransportSession #-}
 
@@ -1310,8 +1301,8 @@ mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSessi
 mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 {-# INLINE mkSMPTSession #-}
 
-getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
-getSessionMode = fmap sessionMode . getNetworkConfig
+getSessionMode :: AgentClient -> IO TransportSessionMode
+getSessionMode = atomically . fmap sessionMode . getNetworkConfig
 {-# INLINE getSessionMode #-}
 
 newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
@@ -1321,12 +1312,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 NoEntity "NEW"
-  tSess <- mkTransportSession c userId srv connId
+  logServer "-->" c srv "" "NEW"
+  tSess <- liftIO $ 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 NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
+  liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
           { userId,
@@ -1351,8 +1342,8 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender
       qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure
   pure (rq, qUri, tSess, sessId)
 
-processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError () -> STM ()
-processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case
+processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> STM ()
+processSubResult c rq@RcvQueue {userId, server, connId} = \case
   Left e ->
     unless (temporaryClientError e) $ do
       incSMPServerStat c userId server connSubErrs
@@ -1360,7 +1351,7 @@ processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case
   Right () ->
     ifM
       (hasPendingSubscription c connId)
-      (incSMPServerStat c userId server connSubscribed >> addSubscription c sessId rq)
+      (incSMPServerStat c userId server connSubscribed >> addSubscription c rq)
       (incSMPServerStat c userId server connSubIgnored)
 
 temporaryAgentError :: AgentErrorType -> Bool
@@ -1408,7 +1399,7 @@ subscribeQueues c qs = do
   (errs <> rs,) <$> readTVarIO session
   where
     checkQueue rq = do
-      prohibited <- liftIO $ hasGetLock c rq
+      prohibited <- atomically $ hasGetLock c rq
       pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
     subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
     subscribeQueues_ env session smp qs' = do
@@ -1431,7 +1422,7 @@ subscribeQueues c qs = do
         sessId = sessionId $ thParams smp
         hasTempErrors = any (either temporaryClientError (const False) . snd)
         processSubResults :: NonEmpty (RcvQueue, Either SMPClientError ()) -> STM ()
-        processSubResults = mapM_ $ uncurry $ processSubResult c sessId
+        processSubResults = mapM_ $ uncurry $ processSubResult c
         resubscribe = resubscribeSMPSession c tSess `runReaderT` env
 
 activeClientSession :: AgentClient -> SMPTransportSession -> SessionId -> STM Bool
@@ -1449,7 +1440,7 @@ sendTSessionBatches statCmd toRQ action c qs =
   where
     batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
     batchQueues = do
-      mode <- getSessionMode c
+      mode <- atomically $ sessionMode <$> getNetworkConfig c
       pure . M.assocs $ foldl' (batch mode) M.empty qs
       where
         batch mode m q =
@@ -1460,7 +1451,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
@@ -1470,10 +1461,10 @@ sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
   where
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
 
-addSubscription :: AgentClient -> SessionId -> RcvQueue -> STM ()
-addSubscription c sessId rq@RcvQueue {connId} = do
+addSubscription :: AgentClient -> RcvQueue -> STM ()
+addSubscription c rq@RcvQueue {connId} = do
   modifyTVar' (subscrConns c) $ S.insert connId
-  RQ.addQueue (sessId, rq) $ activeSubs c
+  RQ.addQueue rq $ activeSubs c
   RQ.deleteQueue rq $ pendingSubs c
 
 failSubscription :: AgentClient -> RcvQueue -> SMPClientError -> STM ()
@@ -1492,7 +1483,7 @@ addNewQueueSubscription c rq tSess sessId = do
     atomically $
       ifM
         (activeClientSession c tSess sessId)
-        (True <$ addSubscription c sessId rq)
+        (True <$ addSubscription c rq)
         (False <$ addPendingSubscription c rq)
   unless same $ resubscribeSMPSession c tSess
 
@@ -1510,43 +1501,36 @@ removeSubscription c connId = do
   RQ.deleteConn connId $ activeSubs c
   RQ.deleteConn connId $ pendingSubs c
 
-getSubscriptions :: AgentClient -> IO (Set ConnId)
-getSubscriptions = readTVarIO . subscrConns
+getSubscriptions :: AgentClient -> STM (Set ConnId)
+getSubscriptions = readTVar . subscrConns
 {-# INLINE getSubscriptions #-}
 
-logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m ()
-logServer dir c srv = logServer' dir c srv . unEntityId
+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]
 {-# 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 :: EntityId -> ByteString
-logSecret = logSecret' . unEntityId
+logSecret :: ByteString -> ByteString
+logSecret bs = B64.encode $ B.take 3 bs
 {-# 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, connId, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
+sendConfirmation c sq@SndQueue {userId, server, 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 connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
+  sendOrProxySMPMessage c userId server "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
 sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
-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
+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
   msg <- mkInvitation
-  sendOrProxySMPMessage c userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
+  sendOrProxySMPMessage c userId smpServer "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
   where
     mkInvitation :: AM ByteString
     -- this is only encrypted with per-queue E2E, not with double ratchet
@@ -1582,8 +1566,8 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
 secureSndQueue :: AgentClient -> SndQueue -> AM ()
-secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
-  void $ sendOrProxySMPCommand c userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
+secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} =
+  void $ sendOrProxySMPCommand c userId server "SKEY <key>" sndId secureViaProxy secureDirectly
   where
     -- TODO track statistics
     secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
@@ -1613,13 +1597,13 @@ 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
 
-hasGetLock :: AgentClient -> RcvQueue -> IO Bool
+hasGetLock :: AgentClient -> RcvQueue -> STM Bool
 hasGetLock c RcvQueue {server, rcvId} =
-  TM.memberIO (server, rcvId) $ getMsgLocks c
+  TM.member (server, rcvId) $ getMsgLocks c
 
 releaseGetLock :: AgentClient -> RcvQueue -> STM ()
 releaseGetLock c RcvQueue {server, rcvId} =
@@ -1647,10 +1631,10 @@ deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c
       pure rs
 
 sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
-sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do
+sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do
   let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
   msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
-  sendOrProxySMPMessage c userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
+  sendOrProxySMPMessage c userId server "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
 
 data ServerQueueInfo = ServerQueueInfo
   { server :: SMPServer,
@@ -1669,7 +1653,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 . unEntityId
+    enc = decodeLatin1 . B64.encode
 
 agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
 agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
@@ -1717,10 +1701,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 NoEntity "FNEW"
-  tSess <- mkTransportSession c userId srv chunkDigest
+  logServer "-->" c srv "" "FNEW"
+  tSess <- liftIO $ mkTransportSession c userId srv chunkDigest
   (sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
-  logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
+  logServer "<--" c srv "" $ 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 ()
@@ -1744,7 +1728,7 @@ xftpRcvKeys n = do
     Just rKeys' -> pure rKeys'
     _ -> throwE $ INTERNAL "non-positive number of recipients"
 
-xftpRcvIdsKeys :: NonEmpty EntityId -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
+xftpRcvIdsKeys :: NonEmpty ByteString -> 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
@@ -1871,28 +1855,16 @@ beginAgentOperation c op = do
   -- unsafeIOToSTM $ putStrLn $ "beginOperation! " <> show op <> " " <> show (opsInProgress s + 1)
   writeTVar opVar $! s {opsInProgress = opsInProgress s + 1}
 
-agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> (AgentClient -> IO ()) -> m a -> m a
+agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> (AgentClient -> STM ()) -> m a -> m a
 agentOperationBracket c op check action =
   E.bracket
-    (liftIO (check c) >> atomically (beginAgentOperation c op))
+    (atomically (check c) >> atomically (beginAgentOperation c op))
     (\_ -> atomically $ endAgentOperation c op)
     (const action)
 
-waitUntilForeground :: AgentClient -> IO ()
-waitUntilForeground c =
-  unlessM (foreground readTVarIO) $ atomically $ unlessM (foreground readTVar) retry
-  where
-    foreground :: Monad m => (TVar AgentState -> m AgentState) -> m Bool
-    foreground rd = (ASForeground ==) <$> rd (agentState c)
-
--- This function waits while agent is suspended, but will proceed while it is suspending,
--- to allow completing in-flight operations.
-waitWhileSuspended :: AgentClient -> IO ()
-waitWhileSuspended c =
-  whenM (suspended readTVarIO) $ atomically $ whenM (suspended readTVar) retry
-  where
-    suspended :: Monad m => (TVar AgentState -> m AgentState) -> m Bool
-    suspended rd = (ASSuspended ==) <$> rd (agentState c)
+waitUntilForeground :: AgentClient -> STM ()
+waitUntilForeground c = unlessM ((ASForeground ==) <$> readTVar (agentState c)) retry
+{-# INLINE waitUntilForeground #-}
 
 withStore' :: AgentClient -> (DB.Connection -> IO a) -> AM a
 withStore' c action = withStore c $ fmap Right . action
@@ -1930,7 +1902,6 @@ withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions)
 storeError :: StoreError -> AgentErrorType
 storeError = \case
   SEConnNotFound -> CONN NOT_FOUND
-  SEUserNotFound -> NO_USER
   SERatchetNotFound -> CONN NOT_FOUND
   SEConnDuplicate -> CONN DUPLICATE
   SEBadConnType CRcv -> CONN SIMPLEX
@@ -1964,7 +1935,7 @@ getNextServer c userId usedSrvs = withUserServers c userId $ \srvs ->
 
 withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a
 withUserServers c userId action =
-  liftIO (TM.lookupIO userId $ userServers c) >>= \case
+  atomically (TM.lookup userId $ userServers c) >>= \case
     Just srvs -> action $ enabledSrvs srvs
     _ -> throwE $ INTERNAL "unknown userId - no user servers"
 
@@ -1972,17 +1943,24 @@ withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> U
 withNextSrv c userId usedSrvs initUsed action = do
   used <- readTVarIO usedSrvs
   srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
-  srvs_ <- liftIO $ TM.lookupIO userId $ userServers c
-  let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_
-      used' = if null unused then initUsed else srv : used
-  atomically $ writeTVar usedSrvs $! used'
+  atomically $ do
+    srvs_ <- TM.lookup userId $ userServers c
+    let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_
+        used' = if null unused then initUsed else srv : used
+    writeTVar usedSrvs $! used'
   action srvAuth
 
 incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()
 incSMPServerStat c userId srv sel = incSMPServerStat' c userId srv sel 1
 
 incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM ()
-incSMPServerStat' = incServerStat (\AgentClient {smpServersStats = s} -> s) newAgentSMPServerStats
+incSMPServerStat' AgentClient {smpServersStats} userId srv sel n = do
+  TM.lookup (userId, srv) smpServersStats >>= \case
+    Just v -> modifyTVar' (sel v) (+ n)
+    Nothing -> do
+      newStats <- newAgentSMPServerStats
+      modifyTVar' (sel newStats) (+ n)
+      TM.insert (userId, srv) newStats smpServersStats
 
 incXFTPServerStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> STM ()
 incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1
@@ -1997,34 +1975,24 @@ incXFTPServerSizeStat = incXFTPServerStat_
 {-# INLINE incXFTPServerSizeStat #-}
 
 incXFTPServerStat_ :: Num n => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> STM ()
-incXFTPServerStat_ = incServerStat (\AgentClient {xftpServersStats = s} -> s) newAgentXFTPServerStats
-{-# INLINE incXFTPServerStat_ #-}
-
-incNtfServerStat :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> STM ()
-incNtfServerStat c userId srv sel = incServerStat (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats c userId srv sel 1
-{-# INLINE incNtfServerStat #-}
-
-incServerStat :: Num n => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> STM ()
-incServerStat statsSel mkNewStats c userId srv sel n = do
-  TM.lookup (userId, srv) (statsSel c) >>= \case
+incXFTPServerStat_ AgentClient {xftpServersStats} userId srv sel n = do
+  TM.lookup (userId, srv) xftpServersStats >>= \case
     Just v -> modifyTVar' (sel v) (+ n)
     Nothing -> do
-      newStats <- mkNewStats
+      newStats <- newAgentXFTPServerStats
       modifyTVar' (sel newStats) (+ n)
-      TM.insert (userId, srv) newStats (statsSel c)
+      TM.insert (userId, srv) newStats xftpServersStats
 
 data AgentServersSummary = AgentServersSummary
   { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
     xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData,
-    ntfServersStats :: Map (UserId, NtfServer) AgentNtfServerStatsData,
     statsStartedAt :: UTCTime,
     smpServersSessions :: Map (UserId, SMPServer) ServerSessions,
     smpServersSubs :: Map (UserId, SMPServer) SMPServerSubs,
     xftpServersSessions :: Map (UserId, XFTPServer) ServerSessions,
     xftpRcvInProgress :: [XFTPServer],
     xftpSndInProgress :: [XFTPServer],
-    xftpDelInProgress :: [XFTPServer],
-    ntfServersSessions :: Map (UserId, NtfServer) ServerSessions
+    xftpDelInProgress :: [XFTPServer]
   }
   deriving (Show)
 
@@ -2041,30 +2009,10 @@ data ServerSessions = ServerSessions
   }
   deriving (Show)
 
-getAgentSubsTotal :: AgentClient -> [UserId] -> IO (SMPServerSubs, Bool)
-getAgentSubsTotal c userIds = do
-  ssActive <- getSubsCount activeSubs
-  ssPending <- getSubsCount pendingSubs
-  sess <- hasSession . M.toList =<< readTVarIO (smpClients c)
-  pure (SMPServerSubs {ssActive, ssPending}, sess)
-  where
-    getSubsCount :: (AgentClient -> TRcvQueues q) -> IO Int
-    getSubsCount subs = M.foldrWithKey' addSub 0 <$> readTVarIO (getRcvQueues $ subs c)
-    addSub :: (UserId, SMPServer, SMP.RecipientId) -> q -> Int -> Int
-    addSub (userId, _, _) _ cnt = if userId `elem` userIds then cnt + 1 else cnt
-    hasSession :: [(SMPTransportSession, SMPClientVar)] -> IO Bool
-    hasSession = \case
-      [] -> pure False
-      (s : ss) -> ifM (isConnected s) (pure True) (hasSession ss)
-    isConnected ((userId, _, _), SessionVar {sessionVar})
-      | userId `elem` userIds = atomically $ maybe False isRight <$> tryReadTMVar sessionVar
-      | otherwise = pure False
-
 getAgentServersSummary :: AgentClient -> IO AgentServersSummary
-getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServersStats, srvStatsStartedAt, agentEnv} = do
+getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt, agentEnv} = do
   sss <- mapM getAgentSMPServerStats =<< readTVarIO smpServersStats
   xss <- mapM getAgentXFTPServerStats =<< readTVarIO xftpServersStats
-  nss <- mapM getAgentNtfServerStats =<< readTVarIO ntfServersStats
   statsStartedAt <- readTVarIO srvStatsStartedAt
   smpServersSessions <- countSessions =<< readTVarIO (smpClients c)
   smpServersSubs <- getServerSubs
@@ -2072,20 +2020,17 @@ getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, ntfServ
   xftpRcvInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpRcvWorkers
   xftpSndInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpSndWorkers
   xftpDelInProgress <- getXFTPWorkerSrvs xftpDelWorkers
-  ntfServersSessions <- countSessions =<< readTVarIO (ntfClients c)
   pure
     AgentServersSummary
       { smpServersStats = sss,
         xftpServersStats = xss,
-        ntfServersStats = nss,
         statsStartedAt,
         smpServersSessions,
         smpServersSubs,
         xftpServersSessions,
         xftpRcvInProgress,
         xftpSndInProgress,
-        xftpDelInProgress,
-        ntfServersSessions
+        xftpDelInProgress
       }
   where
     getServerSubs = do
@@ -2131,7 +2076,6 @@ getAgentSubscriptions c = do
   removedSubscriptions <- getRemovedSubs
   pure $ SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions}
   where
-    getSubs :: (AgentClient -> TRcvQueues q) -> IO [SubInfo]
     getSubs sel = map (`subInfo` Nothing) . M.keys <$> readTVarIO (getRcvQueues $ sel c)
     getRemovedSubs = map (uncurry subInfo . second Just) . M.assocs <$> readTVarIO (removedSubs c)
     subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo

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

@@ -41,7 +41,6 @@ module Simplex.Messaging.Agent.Env.SQLite
   )
 where
 
-import Control.Concurrent (ThreadId)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -52,7 +51,7 @@ import Data.ByteArray (ScrubbedBytes)
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
-import Data.Map.Strict (Map)
+import Data.Map (Map)
 import Data.Maybe (fromMaybe)
 import Data.Time.Clock (NominalDiffTime, nominalDay)
 import Data.Time.Clock.System (SystemTime (..))
@@ -77,9 +76,8 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
 import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
-import System.Mem.Weak (Weak)
 import System.Random (StdGen, newStdGen)
-import UnliftIO (SomeException)
+import UnliftIO (Async, SomeException)
 import UnliftIO.STM
 
 type AM' a = ReaderT Env IO a
@@ -150,7 +148,10 @@ data AgentConfig = AgentConfig
     xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
     ntfCron :: Word16,
+    ntfWorkerDelay :: Int,
+    ntfSMPWorkerDelay :: Int,
     ntfSubCheckInterval :: NominalDiffTime,
+    ntfMaxMessages :: Int,
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
@@ -164,7 +165,7 @@ defaultReconnectInterval =
   RetryInterval
     { initialInterval = 2_000000,
       increaseAfter = 10_000000,
-      maxInterval = 180_000000
+      maxInterval = 60_000000
     }
 
 defaultMessageRetryInterval :: RetryInterval2
@@ -174,7 +175,7 @@ defaultMessageRetryInterval =
         RetryInterval
           { initialInterval = 2_000000,
             increaseAfter = 10_000000,
-            maxInterval = 120_000000
+            maxInterval = 60_000000
           },
       riSlow =
         RetryInterval
@@ -219,7 +220,10 @@ defaultAgentConfig =
       xftpMaxRecipientsPerRequest = 200,
       deleteErrorCount = 10,
       ntfCron = 20, -- minutes
+      ntfWorkerDelay = 100000, -- microseconds
+      ntfSMPWorkerDelay = 500000, -- microseconds
       ntfSubCheckInterval = nominalDay,
+      ntfMaxMessages = 3,
       -- CA certificate private key is not needed for initialization
       -- ! we do not generate these
       caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -244,8 +248,8 @@ newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env
 newSMPAgentEnv config store = do
   random <- C.newRandom
   randomServer <- newTVarIO =<< liftIO newStdGen
-  ntfSupervisor <- newNtfSubSupervisor $ tbqSize config
-  xftpAgent <- newXFTPAgent
+  ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
+  xftpAgent <- atomically newXFTPAgent
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
@@ -262,12 +266,12 @@ data NtfSupervisor = NtfSupervisor
 data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
   deriving (Show)
 
-newNtfSubSupervisor :: Natural -> IO NtfSupervisor
+newNtfSubSupervisor :: Natural -> STM NtfSupervisor
 newNtfSubSupervisor qSize = do
-  ntfTkn <- newTVarIO Nothing
-  ntfSubQ <- newTBQueueIO qSize
-  ntfWorkers <- TM.emptyIO
-  ntfSMPWorkers <- TM.emptyIO
+  ntfTkn <- newTVar Nothing
+  ntfSubQ <- newTBQueue qSize
+  ntfWorkers <- TM.empty
+  ntfSMPWorkers <- TM.empty
   pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
 
 data XFTPAgent = XFTPAgent
@@ -278,12 +282,12 @@ data XFTPAgent = XFTPAgent
     xftpDelWorkers :: TMap XFTPServer Worker
   }
 
-newXFTPAgent :: IO XFTPAgent
+newXFTPAgent :: STM XFTPAgent
 newXFTPAgent = do
-  xftpWorkDir <- newTVarIO Nothing
-  xftpRcvWorkers <- TM.emptyIO
-  xftpSndWorkers <- TM.emptyIO
-  xftpDelWorkers <- TM.emptyIO
+  xftpWorkDir <- newTVar Nothing
+  xftpRcvWorkers <- TM.empty
+  xftpSndWorkers <- TM.empty
+  xftpDelWorkers <- TM.empty
   pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}
 
 tryAgentError :: AM a -> AM (Either AgentErrorType a)
@@ -314,7 +318,7 @@ mkInternal = INTERNAL . show
 data Worker = Worker
   { workerId :: Int,
     doWork :: TMVar (),
-    action :: TMVar (Maybe (Weak ThreadId)),
+    action :: TMVar (Maybe (Async ())),
     restarts :: TVar RestartCount
   }
 

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -20,8 +20,8 @@ where
 
 import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
+import Control.Monad.Except
 import Control.Monad.Reader
-import Control.Monad.Trans.Except
 import Data.Bifunctor (first)
 import qualified Data.Map.Strict as M
 import Data.Text (Text)
@@ -31,7 +31,6 @@ import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Crypto as C
@@ -41,7 +40,7 @@ import Simplex.Messaging.Protocol (NtfServer, SMPServer, sameSrvAddr)
 import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
 import System.Random (randomR)
 import UnliftIO
-import UnliftIO.Concurrent (forkIO)
+import UnliftIO.Concurrent (forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
 
 runNtfSupervisor :: AgentClient -> AM' ()
@@ -65,7 +64,7 @@ processNtfSub c (connId, cmd) = do
   logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
   case cmd of
     NSCCreate -> do
-      (a, RcvQueue {userId, server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
+      (a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
         a <- liftIO $ getNtfSubscription db connId
         q <- ExceptT $ getPrimaryRcvQueue db connId
         pure (a, q)
@@ -75,12 +74,12 @@ processNtfSub c (connId, cmd) = do
           withTokenServer $ \ntfServer -> do
             case clientNtfCreds of
               Just ClientNtfCreds {notifierId} -> do
-                let newSub = newNtfSubscription userId connId smpServer (Just notifierId) ntfServer NASKey
-                withStore c $ \db -> createNtfSubscription db newSub $ NSANtf NSACreate
+                let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
+                withStore c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
                 lift . void $ getNtfNTFWorker True c ntfServer
               Nothing -> do
-                let newSub = newNtfSubscription userId connId smpServer Nothing ntfServer NASNew
-                withStore c $ \db -> createNtfSubscription db newSub $ NSASMP NSASmpKey
+                let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
+                withStore c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
                 lift . void $ getNtfSMPWorker True c smpServer
         (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
           case (clientNtfCreds, ntfQueueId) of
@@ -100,24 +99,24 @@ processNtfSub c (connId, cmd) = do
                     if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
                       then resetSubscription
                       else withTokenServer $ \ntfServer -> do
-                        withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NSANtf NSACreate)
+                        withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
                         lift . void $ getNtfNTFWorker True c ntfServer
                 | otherwise -> case action of
-                    NSANtf _ -> lift . void $ getNtfNTFWorker True c subNtfServer
-                    NSASMP _ -> lift . void $ getNtfSMPWorker True c smpServer
+                    NtfSubNTFAction _ -> lift . void $ getNtfNTFWorker True c subNtfServer
+                    NtfSubSMPAction _ -> lift . void $ getNtfSMPWorker True c smpServer
             rotate :: AM ()
             rotate = do
-              withStore' c $ \db -> supervisorUpdateNtfSub db sub (NSANtf NSARotate)
+              withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
               lift . void $ getNtfNTFWorker True c subNtfServer
             resetSubscription :: AM ()
             resetSubscription =
               withTokenServer $ \ntfServer -> do
                 let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
-                withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NSASMP NSASmpKey)
+                withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
                 lift . void $ getNtfSMPWorker True c smpServer
     NSCDelete -> do
       sub_ <- withStore' c $ \db -> do
-        supervisorUpdateNtfAction db connId (NSANtf NSADelete)
+        supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
         getNtfSubscription db connId
       logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
       case sub_ of
@@ -127,7 +126,7 @@ processNtfSub c (connId, cmd) = do
       withStore' c (`getPrimaryRcvQueue` connId) >>= \case
         Right rq@RcvQueue {server = smpServer} -> do
           logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
-          withStore' c $ \db -> supervisorUpdateNtfAction db connId (NSASMP NSASmpDelete)
+          withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
           lift . void $ getNtfSMPWorker True c smpServer
         _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
     NSCNtfWorker ntfServer -> lift . void $ getNtfNTFWorker True c ntfServer
@@ -147,10 +146,12 @@ withTokenServer :: (NtfServer -> AM ()) -> AM ()
 withTokenServer action = lift getNtfToken >>= mapM_ (\NtfToken {ntfServer} -> action ntfServer)
 
 runNtfWorker :: AgentClient -> NtfServer -> Worker -> AM ()
-runNtfWorker c srv Worker {doWork} =
+runNtfWorker c srv Worker {doWork} = do
+  delay <- asks $ ntfWorkerDelay . config
   forever $ do
     waitForWork doWork
     ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
+    threadDelay delay
   where
     runNtfOperation :: AM ()
     runNtfOperation =
@@ -159,73 +160,70 @@ runNtfWorker c srv Worker {doWork} =
           logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop -> do
-            liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
             processSub nextSub
               `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
     processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
-    processSub (sub@NtfSubscription {userId, connId, smpServer, ntfSubId}, action, actionTs) = do
+    processSub (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
       ts <- liftIO getCurrentTime
       unlessM (lift $ rescheduleAction doWork ts actionTs) $
         case action of
           NSACreate ->
             lift getNtfToken >>= \case
-              Just tkn@NtfToken {ntfServer, ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
+              Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
                 RcvQueue {clientNtfCreds} <- withStore c (`getPrimaryRcvQueue` connId)
                 case clientNtfCreds of
                   Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
-                    atomically $ incNtfServerStat c userId ntfServer ntfCreateAttempts
                     nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
-                    atomically $ incNtfServerStat c userId ntfServer ntfCreated
                     -- possible improvement: smaller retry until Active, less frequently (daily?) once Active
                     let actionTs' = addUTCTime 30 ts
                     withStore' c $ \db ->
-                      updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NSANtf NSACheck) actionTs'
+                      updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs'
                   _ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
               _ -> workerInternalError c connId "NSACreate - no active token"
           NSACheck ->
             lift getNtfToken >>= \case
-              Just tkn@NtfToken {ntfServer} ->
+              Just tkn ->
                 case ntfSubId of
-                  Just nSubId -> do
-                    atomically $ incNtfServerStat c userId ntfServer ntfCheckAttempts
+                  Just nSubId ->
                     agentNtfCheckSubscription c nSubId tkn >>= \case
                       NSAuth -> do
-                        withStore' c $ \db ->
-                          updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NSASMP NSASmpKey) ts
-                        ns <- asks ntfSupervisor
-                        atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+                        lift (getNtfServer c) >>= \case
+                          Just ntfServer -> do
+                            withStore' c $ \db ->
+                              updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
+                            ns <- asks ntfSupervisor
+                            atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+                          _ -> workerInternalError c connId "NSACheck - failed to reset subscription, notification server not configured"
                       status -> updateSubNextCheck ts status
-                    atomically $ incNtfServerStat c userId ntfServer ntfChecked
                   Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
               _ -> workerInternalError c connId "NSACheck - no active token"
-          NSADelete ->
-            deleteNtfSub $ do
-              let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
-              withStore' c $ \db -> updateNtfSubscription db sub' (NSASMP NSASmpDelete) ts
-              ns <- asks ntfSupervisor
-              atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
-          NSARotate ->
-            deleteNtfSub $ do
-              withStore' c $ \db -> deleteNtfSubscription db connId
-              ns <- asks ntfSupervisor
-              atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
+          NSADelete -> case ntfSubId of
+            Just nSubId ->
+              (lift getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
+                `agentFinally` continueDeletion
+            _ -> continueDeletion
+            where
+              continueDeletion = do
+                let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
+                withStore' c $ \db -> updateNtfSubscription db sub' (NtfSubSMPAction NSASmpDelete) ts
+                ns <- asks ntfSupervisor
+                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
+          NSARotate -> case ntfSubId of
+            Just nSubId ->
+              (lift getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
+                `agentFinally` deleteCreate
+            _ -> deleteCreate
+            where
+              deleteCreate = do
+                withStore' c $ \db -> deleteNtfSubscription db connId
+                ns <- asks ntfSupervisor
+                atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
       where
-        deleteNtfSub continue = case ntfSubId of
-          Just nSubId ->
-            lift getNtfToken >>= \case
-              Just tkn@NtfToken {ntfServer} -> do
-                atomically $ incNtfServerStat c userId ntfServer ntfDelAttempts
-                tryAgentError (agentNtfDeleteSubscription c nSubId tkn) >>= \case
-                  Left e | temporaryOrHostError e -> throwE e
-                  _ -> continue
-                atomically $ incNtfServerStat c userId ntfServer ntfDeleted
-              Nothing -> continue
-          _ -> continue
         updateSubNextCheck ts toStatus = do
           checkInterval <- asks $ ntfSubCheckInterval . config
           let nextCheckTs = addUTCTime checkInterval ts
-          updateSub (NASCreated toStatus) (NSANtf NSACheck) nextCheckTs
+          updateSub (NASCreated toStatus) (NtfSubNTFAction NSACheck) nextCheckTs
         updateSub toStatus toAction actionTs' =
           withStore' c $ \db ->
             updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
@@ -233,10 +231,12 @@ runNtfWorker c srv Worker {doWork} =
 runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
 runNtfSMPWorker c srv Worker {doWork} = do
   env <- ask
+  delay <- asks $ ntfSMPWorkerDelay . config
   forever $ do
     waitForWork doWork
     ExceptT . liftIO . agentOperationBracket c AONtfNetwork throwWhenInactive $
       runReaderT (runExceptT runNtfSMPOperation) env
+    threadDelay delay
   where
     runNtfSMPOperation =
       withWork c doWork (`getNextNtfSubSMPAction` srv) $
@@ -244,7 +244,6 @@ runNtfSMPWorker c srv Worker {doWork} = do
           logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop -> do
-            liftIO $ waitWhileSuspended c
             liftIO $ waitForUserNetwork c
             processSub nextSub
               `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
@@ -265,12 +264,11 @@ runNtfSMPWorker c srv Worker {doWork} = do
                 let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
                 withStore' c $ \db -> do
                   setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
-                  updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
+                  updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NtfSubNTFAction NSACreate) ts
                 ns <- asks ntfSupervisor
                 atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
               _ -> workerInternalError c connId "NSASmpKey - no active token"
           NSASmpDelete -> do
-            -- TODO should we remove it after successful removal from the server?
             rq_ <- withStore' c $ \db -> do
               setRcvQueueNtfCreds db connId Nothing
               getPrimaryRcvQueue db connId
@@ -297,7 +295,7 @@ retryOnError c name loop done e = do
   where
     retryLoop = do
       atomically $ endAgentOperation c AONtfNetwork
-      liftIO $ throwWhenInactive c
+      atomically $ throwWhenInactive c
       atomically $ beginAgentOperation c AONtfNetwork
       loop
 

src/Simplex/Messaging/Agent/Protocol.hs

@@ -42,7 +42,6 @@ module Simplex.Messaging.Agent.Protocol
     deliveryRcptsSMPAgentVersion,
     pqdrSMPAgentVersion,
     sndAuthKeySMPAgentVersion,
-    ratchetOnConfSMPAgentVersion,
     currentSMPAgentVersion,
     supportedSMPAgentVRange,
     e2eEncConnInfoLength,
@@ -50,8 +49,6 @@ module Simplex.Messaging.Agent.Protocol
 
     -- * SMP agent protocol types
     ConnInfo,
-    SndQueueSecured,
-    AEntityId,
     ACommand (..),
     AEvent (..),
     AEvt (..),
@@ -156,8 +153,8 @@ import Data.Int (Int64)
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe (fromMaybe, isJust)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -191,6 +188,7 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( AProtocolType,
     BrokerErrorType (..),
+    EntityId,
     ErrorType,
     MsgBody,
     MsgFlags,
@@ -259,14 +257,11 @@ pqdrSMPAgentVersion = VersionSMPA 5
 sndAuthKeySMPAgentVersion :: VersionSMPA
 sndAuthKeySMPAgentVersion = VersionSMPA 6
 
-ratchetOnConfSMPAgentVersion :: VersionSMPA
-ratchetOnConfSMPAgentVersion = VersionSMPA 7
-
 minSupportedSMPAgentVersion :: VersionSMPA
 minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion
 
 currentSMPAgentVersion :: VersionSMPA
-currentSMPAgentVersion = VersionSMPA 7
+currentSMPAgentVersion = VersionSMPA 6
 
 supportedSMPAgentVRange :: VersionRangeSMPA
 supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion
@@ -287,12 +282,10 @@ e2eEncAgentMsgLength v = \case
   _ -> 15856
 
 -- | SMP agent event
-type ATransmission = (ACorrId, AEntityId, AEvt)
+type ATransmission = (ACorrId, EntityId, AEvt)
 
 type UserId = Int64
 
-type AEntityId = ByteString
-
 type ACorrId = ByteString
 
 data AEntity = AEConn | AERcvFile | AESndFile | AENone
@@ -334,8 +327,6 @@ deriving instance Show AEvt
 
 type ConnInfo = ByteString
 
-type SndQueueSecured = Bool
-
 -- | Parameterized type for SMP agent events
 data AEvent (e :: AEntity) where
   INV :: AConnectionRequestUri -> AEvent AEConn
@@ -363,7 +354,6 @@ data AEvent (e :: AEntity) where
   DEL_USER :: Int64 -> AEvent AENone
   STAT :: ConnectionStats -> AEvent AEConn
   OK :: AEvent AEConn
-  JOINED :: SndQueueSecured -> AEvent AEConn
   ERR :: AgentErrorType -> AEvent AEConn
   SUSPENDED :: AEvent AENone
   RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
@@ -432,7 +422,6 @@ data AEventTag (e :: AEntity) where
   DEL_USER_ :: AEventTag AENone
   STAT_ :: AEventTag AEConn
   OK_ :: AEventTag AEConn
-  JOINED_ :: AEventTag AEConn
   ERR_ :: AEventTag AEConn
   SUSPENDED_ :: AEventTag AENone
   -- XFTP commands and responses
@@ -485,7 +474,6 @@ aEventTag = \case
   DEL_USER _ -> DEL_USER_
   STAT _ -> STAT_
   OK -> OK_
-  JOINED _ -> JOINED_
   ERR _ -> ERR_
   SUSPENDED -> SUSPENDED_
   RFPROG {} -> RFPROG_
@@ -1338,8 +1326,6 @@ data AgentErrorType
     CMD {cmdErr :: CommandErrorType, errContext :: String}
   | -- | connection errors
     CONN {connErr :: ConnectionErrorType}
-  | -- | user not found in database
-    NO_USER
   | -- | SMP protocol errors forwarded to agent clients
     SMP {serverAddress :: String, smpErr :: ErrorType}
   | -- | NTF protocol errors forwarded to agent clients

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -9,7 +9,6 @@ module Simplex.Messaging.Agent.RetryInterval
     RI2State (..),
     withRetryInterval,
     withRetryIntervalCount,
-    withRetryForeground,
     withRetryLock2,
     updateRetryInterval2,
     nextRetryDelay,
@@ -17,11 +16,10 @@ module Simplex.Messaging.Agent.RetryInterval
 where
 
 import Control.Concurrent (forkIO)
-import Control.Concurrent.STM (retry)
 import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Int (Int64)
-import Simplex.Messaging.Util (threadDelay', unlessM, whenM)
+import Simplex.Messaging.Util (threadDelay', whenM)
 import UnliftIO.STM
 
 data RetryInterval = RetryInterval
@@ -65,27 +63,6 @@ withRetryIntervalCount ri action = callAction 0 0 $ initialInterval ri
           let elapsed' = elapsed + delay
           callAction (n + 1) elapsed' $ nextRetryDelay elapsed' delay ri
 
-withRetryForeground :: forall m a. MonadIO m => RetryInterval -> STM Bool -> STM Bool -> (Int64 -> m a -> m a) -> m a
-withRetryForeground ri isForeground isOnline action = callAction 0 $ initialInterval ri
-  where
-    callAction :: Int64 -> Int64 -> m a
-    callAction elapsed delay = action delay loop
-      where
-        loop = do
-          -- limit delay to max Int value (~36 minutes on for 32 bit architectures)
-          d <- registerDelay $ fromIntegral $ min delay (fromIntegral (maxBound :: Int))
-          (wasForeground, wasOnline) <- atomically $ (,) <$> isForeground <*> isOnline
-          reset <- atomically $ do
-            foreground <- isForeground
-            online <- isOnline
-            let reset = (not wasForeground && foreground) || (not wasOnline && online)
-            unlessM ((reset ||) <$> readTVar d) retry
-            pure reset
-          let (elapsed', delay')
-                | reset = (0, initialInterval ri)
-                | otherwise = (elapsed + delay, nextRetryDelay elapsed' delay ri)
-          callAction elapsed' delay'
-
 -- This function allows action to toggle between slow and fast retry intervals.
 withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
 withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =

src/Simplex/Messaging/Agent/Stats.hs

@@ -1,20 +1,17 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Messaging.Agent.Stats where
 
-import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..))
 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.Map (Map)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Parsers (defaultJSON, fromTextField_)
-import Simplex.Messaging.Protocol (SMPServer, XFTPServer, NtfServer)
+import Simplex.Messaging.Protocol (SMPServer, XFTPServer)
 import Simplex.Messaging.Util (decodeJSON, encodeJSON)
 import UnliftIO.STM
 
@@ -47,12 +44,7 @@ data AgentSMPServerStats = AgentSMPServerStats
     connSubscribed :: TVar Int, -- total successful subscription
     connSubAttempts :: TVar Int, -- subscription attempts
     connSubIgnored :: TVar Int, -- subscription results ignored (client switched to different session or it was not pending)
-    connSubErrs :: TVar Int, -- permanent subscription errors (temporary accounted for in attempts)
-    -- notifications stats
-    ntfKey :: TVar Int,
-    ntfKeyAttempts :: TVar Int,
-    ntfKeyDeleted :: TVar Int,
-    ntfKeyDeleteAttempts :: TVar Int
+    connSubErrs :: TVar Int -- permanent subscription errors (temporary accounted for in attempts)
   }
 
 data AgentSMPServerStatsData = AgentSMPServerStatsData
@@ -83,17 +75,10 @@ data AgentSMPServerStatsData = AgentSMPServerStatsData
     _connSubscribed :: Int,
     _connSubAttempts :: Int,
     _connSubIgnored :: Int,
-    _connSubErrs :: Int,
-    _ntfKey :: OptionalInt,
-    _ntfKeyAttempts :: OptionalInt,
-    _ntfKeyDeleted :: OptionalInt,
-    _ntfKeyDeleteAttempts :: OptionalInt
+    _connSubErrs :: Int
   }
   deriving (Show)
 
-newtype OptionalInt = OInt {toInt :: Int}
-  deriving (Num, Show, ToJSON)
-
 newAgentSMPServerStats :: STM AgentSMPServerStats
 newAgentSMPServerStats = do
   sentDirect <- newTVar 0
@@ -124,10 +109,6 @@ newAgentSMPServerStats = do
   connSubAttempts <- newTVar 0
   connSubIgnored <- newTVar 0
   connSubErrs <- newTVar 0
-  ntfKey <- newTVar 0
-  ntfKeyAttempts <- newTVar 0
-  ntfKeyDeleted <- newTVar 0
-  ntfKeyDeleteAttempts <- newTVar 0
   pure
     AgentSMPServerStats
       { sentDirect,
@@ -157,11 +138,7 @@ newAgentSMPServerStats = do
         connSubscribed,
         connSubAttempts,
         connSubIgnored,
-        connSubErrs,
-        ntfKey,
-        ntfKeyAttempts,
-        ntfKeyDeleted,
-        ntfKeyDeleteAttempts
+        connSubErrs
       }
 
 newAgentSMPServerStatsData :: AgentSMPServerStatsData
@@ -194,11 +171,7 @@ newAgentSMPServerStatsData =
       _connSubscribed = 0,
       _connSubAttempts = 0,
       _connSubIgnored = 0,
-      _connSubErrs = 0,
-      _ntfKey = 0,
-      _ntfKeyAttempts = 0,
-      _ntfKeyDeleted = 0,
-      _ntfKeyDeleteAttempts = 0
+      _connSubErrs = 0
     }
 
 newAgentSMPServerStats' :: AgentSMPServerStatsData -> STM AgentSMPServerStats
@@ -231,10 +204,6 @@ newAgentSMPServerStats' s = do
   connSubAttempts <- newTVar $ _connSubAttempts s
   connSubIgnored <- newTVar $ _connSubIgnored s
   connSubErrs <- newTVar $ _connSubErrs s
-  ntfKey <- newTVar $ toInt $ _ntfKey s
-  ntfKeyAttempts <- newTVar $ toInt $ _ntfKeyAttempts s
-  ntfKeyDeleted <- newTVar $ toInt $ _ntfKeyDeleted s
-  ntfKeyDeleteAttempts <- newTVar $ toInt $ _ntfKeyDeleteAttempts s
   pure
     AgentSMPServerStats
       { sentDirect,
@@ -264,11 +233,7 @@ newAgentSMPServerStats' s = do
         connSubscribed,
         connSubAttempts,
         connSubIgnored,
-        connSubErrs,
-        ntfKey,
-        ntfKeyAttempts,
-        ntfKeyDeleted,
-        ntfKeyDeleteAttempts
+        connSubErrs
       }
 
 -- as this is used to periodically update stats in db,
@@ -303,10 +268,6 @@ getAgentSMPServerStats s = do
   _connSubAttempts <- readTVarIO $ connSubAttempts s
   _connSubIgnored <- readTVarIO $ connSubIgnored s
   _connSubErrs <- readTVarIO $ connSubErrs s
-  _ntfKey <- OInt <$> readTVarIO (ntfKey s)
-  _ntfKeyAttempts <- OInt <$> readTVarIO (ntfKeyAttempts s)
-  _ntfKeyDeleted <- OInt <$> readTVarIO (ntfKeyDeleted s)
-  _ntfKeyDeleteAttempts <- OInt <$> readTVarIO (ntfKeyDeleteAttempts s)
   pure
     AgentSMPServerStatsData
       { _sentDirect,
@@ -336,11 +297,7 @@ getAgentSMPServerStats s = do
         _connSubscribed,
         _connSubAttempts,
         _connSubIgnored,
-        _connSubErrs,
-        _ntfKey,
-        _ntfKeyAttempts,
-        _ntfKeyDeleted,
-        _ntfKeyDeleteAttempts
+        _connSubErrs
       }
 
 addSMPStatsData :: AgentSMPServerStatsData -> AgentSMPServerStatsData -> AgentSMPServerStatsData
@@ -373,11 +330,7 @@ addSMPStatsData sd1 sd2 =
       _connSubscribed = _connSubscribed sd1 + _connSubscribed sd2,
       _connSubAttempts = _connSubAttempts sd1 + _connSubAttempts sd2,
       _connSubIgnored = _connSubIgnored sd1 + _connSubIgnored sd2,
-      _connSubErrs = _connSubErrs sd1 + _connSubErrs sd2,
-      _ntfKey = _ntfKey sd1 + _ntfKey sd2,
-      _ntfKeyAttempts = _ntfKeyAttempts sd1 + _ntfKeyAttempts sd2,
-      _ntfKeyDeleted = _ntfKeyDeleted sd1 + _ntfKeyDeleted sd2,
-      _ntfKeyDeleteAttempts = _ntfKeyDeleteAttempts sd1 + _ntfKeyDeleteAttempts sd2
+      _connSubErrs = _connSubErrs sd1 + _connSubErrs sd2
     }
 
 data AgentXFTPServerStats = AgentXFTPServerStats
@@ -537,127 +490,18 @@ addXFTPStatsData sd1 sd2 =
       _deleteErrs = _deleteErrs sd1 + _deleteErrs sd2
     }
 
-data AgentNtfServerStats = AgentNtfServerStats
-  { ntfCreated :: TVar Int,
-    ntfCreateAttempts :: TVar Int,
-    ntfChecked :: TVar Int,
-    ntfCheckAttempts :: TVar Int,
-    ntfDeleted :: TVar Int,
-    ntfDelAttempts :: TVar Int
-  }
-
-data AgentNtfServerStatsData = AgentNtfServerStatsData
-  { _ntfCreated :: Int,
-    _ntfCreateAttempts :: Int,
-    _ntfChecked :: Int,
-    _ntfCheckAttempts :: Int,
-    _ntfDeleted :: Int,
-    _ntfDelAttempts :: Int
-  }
-  deriving (Show)
-
-newAgentNtfServerStats :: STM AgentNtfServerStats
-newAgentNtfServerStats = do
-  ntfCreated <- newTVar 0
-  ntfCreateAttempts <- newTVar 0
-  ntfChecked <- newTVar 0
-  ntfCheckAttempts <- newTVar 0
-  ntfDeleted <- newTVar 0
-  ntfDelAttempts <- newTVar 0
-  pure
-    AgentNtfServerStats
-      { ntfCreated,
-        ntfCreateAttempts,
-        ntfChecked,
-        ntfCheckAttempts,
-        ntfDeleted,
-        ntfDelAttempts
-      }
-
-newAgentNtfServerStatsData :: AgentNtfServerStatsData
-newAgentNtfServerStatsData =
-  AgentNtfServerStatsData
-    { _ntfCreated = 0,
-      _ntfCreateAttempts = 0,
-      _ntfChecked = 0,
-      _ntfCheckAttempts = 0,
-      _ntfDeleted = 0,
-      _ntfDelAttempts = 0
-    }
-
-newAgentNtfServerStats' :: AgentNtfServerStatsData -> STM AgentNtfServerStats
-newAgentNtfServerStats' s = do
-  ntfCreated <- newTVar $ _ntfCreated s
-  ntfCreateAttempts <- newTVar $ _ntfCreateAttempts s
-  ntfChecked <- newTVar $ _ntfChecked s
-  ntfCheckAttempts <- newTVar $ _ntfCheckAttempts s
-  ntfDeleted <- newTVar $ _ntfDeleted s
-  ntfDelAttempts <- newTVar $ _ntfDelAttempts s
-  pure
-    AgentNtfServerStats
-      { ntfCreated,
-        ntfCreateAttempts,
-        ntfChecked,
-        ntfCheckAttempts,
-        ntfDeleted,
-        ntfDelAttempts
-      }
-
-getAgentNtfServerStats :: AgentNtfServerStats -> IO AgentNtfServerStatsData
-getAgentNtfServerStats s = do
-  _ntfCreated <- readTVarIO $ ntfCreated s
-  _ntfCreateAttempts <- readTVarIO $ ntfCreateAttempts s
-  _ntfChecked <- readTVarIO $ ntfChecked s
-  _ntfCheckAttempts <- readTVarIO $ ntfCheckAttempts s
-  _ntfDeleted <- readTVarIO $ ntfDeleted s
-  _ntfDelAttempts <- readTVarIO $ ntfDelAttempts s
-  pure
-    AgentNtfServerStatsData
-      { _ntfCreated,
-        _ntfCreateAttempts,
-        _ntfChecked,
-        _ntfCheckAttempts,
-        _ntfDeleted,
-        _ntfDelAttempts
-      }
-
-addNtfStatsData :: AgentNtfServerStatsData -> AgentNtfServerStatsData -> AgentNtfServerStatsData
-addNtfStatsData sd1 sd2 =
-  AgentNtfServerStatsData
-    { _ntfCreated = _ntfCreated sd1 + _ntfCreated sd2,
-      _ntfCreateAttempts = _ntfCreateAttempts sd1 + _ntfCreateAttempts sd2,
-      _ntfChecked = _ntfChecked sd1 + _ntfChecked sd2,
-      _ntfCheckAttempts = _ntfCheckAttempts sd1 + _ntfCheckAttempts sd2,
-      _ntfDeleted = _ntfDeleted sd1 + _ntfDeleted sd2,
-      _ntfDelAttempts = _ntfDelAttempts sd1 + _ntfDelAttempts sd2
-    }
-
 -- Type for gathering both smp and xftp stats across all users and servers,
 -- to then be persisted to db as a single json.
 data AgentPersistedServerStats = AgentPersistedServerStats
   { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
-    xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData,
-    ntfServersStats :: OptionalMap (UserId, NtfServer) AgentNtfServerStatsData
+    xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData
   }
   deriving (Show)
 
-instance FromJSON OptionalInt where
-  parseJSON v = OInt <$> parseJSON v
-  omittedField = Just (OInt 0)
-
-newtype OptionalMap k v = OptionalMap (Map k v)
-  deriving (Show, ToJSON)
-
-instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (OptionalMap k v) where
-  parseJSON v = OptionalMap <$> parseJSON v
-  omittedField = Just (OptionalMap M.empty)
-
 $(J.deriveJSON defaultJSON ''AgentSMPServerStatsData)
 
 $(J.deriveJSON defaultJSON ''AgentXFTPServerStatsData)
 
-$(J.deriveJSON defaultJSON ''AgentNtfServerStatsData)
-
 $(J.deriveJSON defaultJSON ''AgentPersistedServerStats)
 
 instance ToField AgentPersistedServerStats where

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

@@ -1,12 +1,10 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -17,7 +15,6 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
@@ -60,7 +57,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     getDeletedConns,
     getConnData,
     setConnDeleted,
-    setConnUserId,
     setConnAgentVersion,
     setConnPQSupport,
     getDeletedConnIds,
@@ -114,7 +110,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     getSndMsgViaRcpt,
     updateSndMsgRcpt,
     getPendingQueueMsg,
-    getConnectionsForDelivery,
     updatePendingMsgRIState,
     deletePendingMsgs,
     getExpiredSndMessages,
@@ -140,7 +135,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     createCommand,
     getPendingCommandServers,
     getPendingServerCommand,
-    updateCommandServer,
     deleteCommand,
     -- Notification device token persistence
     createNtfToken,
@@ -226,7 +220,7 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- * utilities
     withConnection,
     withTransaction,
-    withTransactionPriority,
+    withTransactionCtx,
     firstRow,
     firstRow',
     maybeFirstRow,
@@ -398,10 +392,10 @@ connectSQLiteStore dbFilePath key keepKey = do
   dbNew <- not <$> doesFileExist dbFilePath
   dbConn <- dbBusyLoop (connectDB dbFilePath key)
   dbConnection <- newMVar dbConn
-  dbKey <- newTVarIO $! storeKey key keepKey
-  dbClosed <- newTVarIO False
-  dbSem <- newTVarIO 0
-  pure SQLiteStore {dbFilePath, dbKey, dbSem, dbConnection, dbNew, dbClosed}
+  atomically $ do
+    dbKey <- newTVar $! storeKey key keepKey
+    dbClosed <- newTVar False
+    pure SQLiteStore {dbFilePath, dbKey, dbConnection, dbNew, dbClosed}
 
 connectDB :: FilePath -> ScrubbedBytes -> IO DB.Connection
 connectDB path key = do
@@ -971,12 +965,12 @@ createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, i
   insertRcvMsgDetails_ db connId rq rcvMsgData
   updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
 
-updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
-updateSndIds db connId = runExceptT $ do
-  (lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId
+updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
+updateSndIds db connId = do
+  (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ db connId
   let internalId = InternalId $ unId lastInternalId + 1
       internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
-  liftIO $ updateLastIdsSnd_ db connId internalId internalSndId
+  updateLastIdsSnd_ db connId internalId internalSndId
   pure (internalId, internalSndId, prevSndHash)
 
 createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO ()
@@ -1014,10 +1008,6 @@ updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} =
     "UPDATE snd_messages SET rcpt_internal_id = ?, rcpt_status = ? WHERE conn_id = ? AND internal_snd_id = ?"
     (agentMsgId, msgRcptStatus, connId, sndMsgId)
 
-getConnectionsForDelivery :: DB.Connection -> IO [ConnId]
-getConnectionsForDelivery db =
-  map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0"
-
 getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
 getPendingQueueMsg db connId SndQueue {dbQueueId} =
   getWorkItem "message" getMsgId getMsgData markMsgFailed
@@ -1327,39 +1317,38 @@ getPendingCommandServers db connId = do
   where
     smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
 
-getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
-getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
+getPendingServerCommand :: DB.Connection -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
+getPendingServerCommand db 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 conn_id = ? AND host IS NULL AND port IS NULL AND failed = 0
+              WHERE 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 conn_id = ? AND host = ? AND port = ? AND failed = 0
+              WHERE host = ? AND port = ? AND failed = 0
               ORDER BY created_at ASC, command_id ASC
               LIMIT 1
             |]
-            (connId, host, port)
+            (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.command
+            SELECT c.corr_id, cs.user_id, c.conn_id, c.command
             FROM commands c
             JOIN connections cs USING (conn_id)
             WHERE c.command_id = ?
@@ -1367,22 +1356,9 @@ getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getComma
           (Only cmdId)
       where
         err = SEInternal $ "command  " <> bshow cmdId <> " returned []"
-        pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
+        pendingCommand (corrId, userId, connId, 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)
@@ -1481,24 +1457,23 @@ getNtfSubscription db connId =
     DB.query
       db
       [sql|
-        SELECT c.user_id, s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash,
+        SELECT s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash,
           nsb.smp_ntf_id, nsb.ntf_sub_id, nsb.ntf_sub_status, nsb.ntf_sub_action, nsb.ntf_sub_smp_action, nsb.ntf_sub_action_ts
         FROM ntf_subscriptions nsb
-        JOIN connections c USING (conn_id)
         JOIN servers s ON s.host = nsb.smp_host AND s.port = nsb.smp_port
         JOIN ntf_servers ns USING (ntf_host, ntf_port)
         WHERE nsb.conn_id = ?
       |]
       (Only connId)
   where
-    ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash ) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
+    ntfSubscription (smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_) =
       let smpServer = SMPServer smpHost smpPort smpKeyHash
           ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
           action = case (ntfAction_, smpAction_, actionTs_) of
-            (Just ntfAction, Nothing, Just actionTs) -> Just (NSANtf ntfAction, actionTs)
-            (Nothing, Just smpAction, Just actionTs) -> Just (NSASMP smpAction, actionTs)
+            (Just ntfAction, Nothing, Just actionTs) -> Just (NtfSubNTFAction ntfAction, actionTs)
+            (Nothing, Just smpAction, Just actionTs) -> Just (NtfSubSMPAction smpAction, actionTs)
             _ -> Nothing
-       in (NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}, action)
+       in (NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}, action)
 
 createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO (Either StoreError ())
 createNtfSubscription db ntfSubscription action = runExceptT $ do
@@ -1632,19 +1607,18 @@ getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
         DB.query
           db
           [sql|
-            SELECT c.user_id, s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash),
+            SELECT s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash),
               ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action
             FROM ntf_subscriptions ns
-            JOIN connections c USING (conn_id)
             JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port
             WHERE ns.conn_id = ?
           |]
           (Only connId)
       where
         err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
-        ntfSubAction (userId, smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
+        ntfSubAction (smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
           let smpServer = SMPServer smpHost smpPort smpKeyHash
-              ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
+              ntfSubscription = NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
            in (ntfSubscription, action, actionTs)
 
 markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO ()
@@ -1676,19 +1650,18 @@ getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
         DB.query
           db
           [sql|
-            SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
+            SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash,
               ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
             FROM ntf_subscriptions ns
-            JOIN connections c USING (conn_id)
             JOIN ntf_servers s USING (ntf_host, ntf_port)
             WHERE ns.conn_id = ?
           |]
           (Only connId)
       where
         err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
-        ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
+        ntfSubAction (ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
           let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
-              ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
+              ntfSubscription = NtfSubscription {connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
            in (ntfSubscription, action, actionTs)
 
 markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO ()
@@ -1817,14 +1790,6 @@ 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
@@ -1941,11 +1906,9 @@ newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
 
 getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getConn = getAnyConn False
-{-# INLINE getConn #-}
 
 getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getDeletedConn = getAnyConn True
-{-# INLINE getDeletedConn #-}
 
 getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
 getAnyConn deleted' dbConn connId =
@@ -1966,11 +1929,9 @@ getAnyConn deleted' dbConn connId =
 
 getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getConns = getAnyConns_ False
-{-# INLINE getConns #-}
 
 getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getDeletedConns = getAnyConns_ True
-{-# INLINE getDeletedConns #-}
 
 getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
 getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
@@ -2003,10 +1964,6 @@ setConnDeleted db waitDelivery connId
   | otherwise =
       DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
 
-setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO ()
-setConnUserId db oldUserId connId newUserId = 
-  DB.execute db "UPDATE connections SET user_id = ? WHERE conn_id = ? and user_id = ?" (newUserId, connId, oldUserId)
-
 setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO ()
 setConnAgentVersion db connId aVersion =
   DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId)
@@ -2219,9 +2176,9 @@ updateRcvMsgHash db connId sndMsgId internalRcvId internalHash =
 
 -- * updateSndIds helpers
 
-retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
+retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
 retrieveLastIdsAndHashSnd_ dbConn connId = do
-  firstRow id SEConnNotFound $
+  [(lastInternalId, lastInternalSndId, lastSndHash)] <-
     DB.queryNamed
       dbConn
       [sql|
@@ -2230,6 +2187,7 @@ retrieveLastIdsAndHashSnd_ dbConn connId = do
         WHERE conn_id = :conn_id;
       |]
       [":conn_id" := connId]
+  return (lastInternalId, lastInternalSndId, lastSndHash)
 
 updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO ()
 updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
@@ -2314,8 +2272,8 @@ randomId :: TVar ChaChaDRG -> Int -> IO ByteString
 randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar
 
 ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction)
-ntfSubAndSMPAction (NSANtf action) = (Just action, Nothing)
-ntfSubAndSMPAction (NSASMP action) = (Nothing, Just action)
+ntfSubAndSMPAction (NtfSubNTFAction action) = (Just action, Nothing)
+ntfSubAndSMPAction (NtfSubSMPAction action) = (Nothing, Just action)
 
 createXFTPServer_ :: DB.Connection -> XFTPServer -> IO Int64
 createXFTPServer_ db newSrv@ProtocolServer {host, port, keyHash} =
@@ -2525,7 +2483,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO ()
 deleteRcvFile' db rcvFileId =
   DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId)
 
-getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool, Maybe RcvFileId)))
+getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool)))
 getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
   getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
   where
@@ -2549,7 +2507,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
             LIMIT 1
           |]
           (host, port, keyHash, RFSReceiving, cutoffTs)
-    getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool, Maybe RcvFileId))
+    getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool))
     getChunkData (rcvFileChunkReplicaId, _fileId) =
       firstRow toChunk SEFileNotFound $
         DB.query
@@ -2558,7 +2516,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
             SELECT
               f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
               r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries,
-              f.approved_relays, f.redirect_entity_id
+              f.approved_relays
             FROM rcv_file_chunk_replicas r
             JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
             JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
@@ -2567,8 +2525,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
           |]
           (Only rcvFileChunkReplicaId)
       where
-        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId)
-        toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) =
+        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool)
+        toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) =
           ( RcvFileChunk
               { rcvFileId,
                 rcvFileEntityId,
@@ -2581,8 +2539,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
                 chunkTmpPath,
                 replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
               },
-            approvedRelays,
-            redirectEntityId_
+            approvedRelays
           )
 
 getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile))

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

@@ -1,5 +1,4 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -9,20 +8,20 @@ module Simplex.Messaging.Agent.Store.SQLite.Common
     withConnection',
     withTransaction,
     withTransaction',
-    withTransactionPriority,
+    withTransactionCtx,
     dbBusyLoop,
     storeKey,
   )
 where
 
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.STM (retry)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
 import Database.SQLite.Simple (SQLError)
 import qualified Database.SQLite.Simple as SQL
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Util (ifM, unlessM)
+import Simplex.Messaging.Util (diffToMilliseconds)
 import qualified UnliftIO.Exception as E
 import UnliftIO.MVar
 import UnliftIO.STM
@@ -33,40 +32,35 @@ storeKey key keepKey = if keepKey || BA.null key then Just key else Nothing
 data SQLiteStore = SQLiteStore
   { dbFilePath :: FilePath,
     dbKey :: TVar (Maybe ScrubbedBytes),
-    dbSem :: TVar Int,
     dbConnection :: MVar DB.Connection,
     dbClosed :: TVar Bool,
     dbNew :: Bool
   }
 
-withConnectionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a
-withConnectionPriority SQLiteStore {dbSem, dbConnection} priority action
-  | priority = E.bracket_ signal release $ withMVar dbConnection action
-  | otherwise = lowPriority
-  where
-    lowPriority = wait >> withMVar dbConnection (\db -> ifM free (Just <$> action db) (pure Nothing)) >>= maybe lowPriority pure
-    signal = atomically $ modifyTVar' dbSem (+ 1)
-    release = atomically $ modifyTVar' dbSem $ \sem -> if sem > 0 then sem - 1 else 0
-    wait = unlessM free $ atomically $ unlessM ((0 ==) <$> readTVar dbSem) retry
-    free = (0 ==) <$> readTVarIO dbSem
-
 withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withConnection st = withConnectionPriority st False
+withConnection SQLiteStore {dbConnection} = withMVar dbConnection
 
 withConnection' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a
 withConnection' st action = withConnection st $ action . DB.conn
 
+withTransaction :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withTransaction = withTransactionCtx Nothing
+
 withTransaction' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a
 withTransaction' st action = withTransaction st $ action . DB.conn
 
-withTransaction :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
-withTransaction st = withTransactionPriority st False
-{-# INLINE withTransaction #-}
-
-withTransactionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a
-withTransactionPriority st priority action = withConnectionPriority st priority $ dbBusyLoop . transaction
+withTransactionCtx :: Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
+withTransactionCtx ctx_ st action = withConnection st $ dbBusyLoop . transactionWithCtx
   where
-    transaction db@DB.Connection {conn} = SQL.withImmediateTransaction conn $ action db
+    transactionWithCtx db@DB.Connection {conn} = case ctx_ of
+      Nothing -> SQL.withImmediateTransaction conn $ action db
+      Just ctx -> do
+        t1 <- getCurrentTime
+        r <- SQL.withImmediateTransaction conn $ action db
+        t2 <- getCurrentTime
+        putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
+        putStrLn $ "withTransactionCtx end   :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
+        pure r
 
 dbBusyLoop :: forall a. IO a -> IO a
 dbBusyLoop action = loop 500 3000000

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

@@ -1,5 +1,4 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -21,19 +20,15 @@ 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, tshow)
+import Simplex.Messaging.Util (diffToMilliseconds)
 
 data Connection = Connection
   { conn :: SQL.Connection,
@@ -43,41 +38,33 @@ data Connection = Connection
 data SlowQueryStats = SlowQueryStats
   { count :: Int64,
     timeMax :: Int64,
-    timeAvg :: Int64,
-    errs :: Map Text Int
+    timeAvg :: Int64
   }
   deriving (Show)
 
 timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a
 timeIt slow sql a = do
   t <- getCurrentTime
-  r <- a `catch` \e -> do
-    atomically $ TM.alter (Just . updateQueryErrors e) sql slow
-    throwIO e
+  r <- a
   t' <- getCurrentTime
   let diff = diffToMilliseconds $ diffUTCTime t' t
-  when (diff > 1) $ atomically $ TM.alter (updateQueryStats diff) sql slow
+  atomically $ when (diff > 5) $ 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 M.empty
-    updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg, errs}) =
+    updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff
+    updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg}) =
       Just $
         SlowQueryStats
           { count = count + 1,
             timeMax = max timeMax diff,
-            timeAvg = (timeAvg * count + diff) `div` (count + 1),
-            errs
+            timeAvg = (timeAvg * count + diff) `div` (count + 1)
           }
 
 open :: String -> IO Connection
 open f = do
   conn <- SQL.open f
-  slow <- TM.emptyIO
+  slow <- atomically $ TM.empty
   pure Connection {conn, slow}
 
 close :: Connection -> IO ()

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.Strict as M
+import qualified Data.Map as M
 import Data.Maybe (isNothing, mapMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeLatin1)

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -1,9 +1,7 @@
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Simplex.Messaging.Agent.TRcvQueues
   ( TRcvQueues (getRcvQueues, getConnections),
-    Queue (..),
     empty,
     clear,
     deleteConn,
@@ -11,9 +9,9 @@ module Simplex.Messaging.Agent.TRcvQueues
     addQueue,
     batchAddQueues,
     deleteQueue,
-    hasSessQueues,
     getSessQueues,
     getDelSessQueues,
+    qKey,
   )
 where
 
@@ -27,51 +25,46 @@ import Simplex.Messaging.Agent.Store (RcvQueue, StoredRcvQueue (..))
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport
-
-class Queue q where
-  connId' :: q -> 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.
-data TRcvQueues q = TRcvQueues
-  { getRcvQueues :: TMap (UserId, SMPServer, RecipientId) q,
+data TRcvQueues = TRcvQueues
+  { getRcvQueues :: TMap (UserId, SMPServer, RecipientId) RcvQueue,
     getConnections :: TMap ConnId (NonEmpty (UserId, SMPServer, RecipientId))
   }
 
-empty :: IO (TRcvQueues q)
-empty = TRcvQueues <$> TM.emptyIO <*> TM.emptyIO
+empty :: STM TRcvQueues
+empty = TRcvQueues <$> TM.empty <*> TM.empty
 
-clear :: TRcvQueues q -> STM ()
+clear :: TRcvQueues -> STM ()
 clear (TRcvQueues qs cs) = TM.clear qs >> TM.clear cs
 
-deleteConn :: ConnId -> TRcvQueues q -> STM ()
+deleteConn :: ConnId -> TRcvQueues -> STM ()
 deleteConn cId (TRcvQueues qs cs) =
   TM.lookupDelete cId cs >>= \case
     Just ks -> modifyTVar' qs $ \qs' -> foldl' (flip M.delete) qs' ks
     Nothing -> pure ()
 
-hasConn :: ConnId -> TRcvQueues q -> STM Bool
+hasConn :: ConnId -> TRcvQueues -> STM Bool
 hasConn cId (TRcvQueues _ cs) = TM.member cId cs
 
-addQueue :: Queue q => q -> TRcvQueues q -> STM ()
+addQueue :: RcvQueue -> TRcvQueues -> STM ()
 addQueue rq (TRcvQueues qs cs) = do
   TM.insert k rq qs
-  TM.alter addQ (connId' rq) cs
+  TM.alter addQ (connId rq) cs
   where
     addQ = Just . maybe (k :| []) (k <|)
     k = qKey rq
 
--- Save time by aggregating modifyTVar'
-batchAddQueues :: (Foldable t, Queue q) => TRcvQueues q -> t q -> STM ()
+-- Save time by aggregating modifyTVar
+batchAddQueues :: Foldable t => TRcvQueues -> t RcvQueue -> STM ()
 batchAddQueues (TRcvQueues qs cs) rqs = do
   modifyTVar' qs $ \now -> foldl' (\rqs' rq -> M.insert (qKey rq) rq rqs') now rqs
-  modifyTVar' cs $ \now -> foldl' (\cs' rq -> M.alter (addQ $ qKey rq) (connId' rq) cs') now rqs
+  modifyTVar' cs $ \now -> foldl' (\cs' rq -> M.alter (addQ $ qKey rq) (connId rq) cs') now rqs
   where
     addQ k = Just . maybe (k :| []) (k <|)
 
-deleteQueue :: RcvQueue -> TRcvQueues RcvQueue -> STM ()
+deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
 deleteQueue rq (TRcvQueues qs cs) = do
   TM.delete k qs
   TM.update delQ (connId rq) cs
@@ -79,25 +72,21 @@ deleteQueue rq (TRcvQueues qs cs) = do
     delQ = L.nonEmpty . L.filter (/= k)
     k = qKey rq
 
-hasSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues RcvQueue -> STM Bool
-hasSessQueues tSess (TRcvQueues qs _) = any (`isSession` tSess) <$> readTVar qs
-
-getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues RcvQueue -> IO [RcvQueue]
-getSessQueues tSess (TRcvQueues qs _) = M.foldl' addQ [] <$> readTVarIO qs
+getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
+getSessQueues tSess (TRcvQueues qs _) = M.foldl' addQ [] <$> readTVar qs
   where
     addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs'
 
-getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> SessionId -> TRcvQueues (SessionId, RcvQueue) -> STM ([RcvQueue], [ConnId])
-getDelSessQueues tSess sessId' (TRcvQueues qs cs) = do
+getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM ([RcvQueue], [ConnId])
+getDelSessQueues tSess (TRcvQueues qs cs) = do
   (removedQs, qs'') <- (\qs' -> M.foldl' delQ ([], qs') qs') <$> readTVar qs
   writeTVar qs $! qs''
   removedConns <- stateTVar cs $ \cs' -> foldl' delConn ([], cs') removedQs
   pure (removedQs, removedConns)
   where
-    delQ acc@(removed, qs') (sessId, rq)
-      | rq `isSession` tSess && sessId == sessId' = (rq : removed, M.delete (qKey rq) qs')
+    delQ acc@(removed, qs') rq
+      | rq `isSession` tSess = (rq : removed, M.delete (qKey rq) qs')
       | otherwise = acc
-    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
@@ -111,10 +100,5 @@ isSession :: RcvQueue -> (UserId, SMPServer, Maybe ConnId) -> Bool
 isSession rq (uId, srv, connId_) =
   userId rq == uId && server rq == srv && maybe True (connId rq ==) connId_
 
-instance Queue RcvQueue where
-  connId' = connId
-  qKey rq = (userId rq, server rq, rcvId rq)
-
-instance Queue (SessionId, RcvQueue) where
-  connId' = connId . snd
-  qKey = qKey . snd
+qKey :: RcvQueue -> (UserId, SMPServer, ConnId)
+qKey rq = (userId rq, server rq, connId rq)

src/Simplex/Messaging/Client.hs

@@ -58,10 +58,6 @@ module Simplex.Messaging.Client
     suspendSMPQueue,
     deleteSMPQueue,
     deleteSMPQueues,
-    createSMPDataBlob,
-    deleteSMPDataBlob,
-    getSMPDataBlob,
-    proxyGetSMPDataBlob,
     connectSMPProxiedRelay,
     proxySMPMessage,
     forwardSMPTransmission,
@@ -118,8 +114,6 @@ import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bitraversable (bimapM)
-import qualified Data.ByteArray as BA
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
@@ -176,17 +170,17 @@ data PClient v err msg = PClient
     msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
   }
 
-smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> IO SMPClient
+smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient
 smpClientStub g sessionId thVersion thAuth = do
   let ts = UTCTime (read "2024-03-31") 0
-  connected <- newTVarIO False
-  clientCorrId <- atomically $ C.newRandomDRG g
-  sentCommands <- TM.emptyIO
-  sendPings <- newTVarIO False
-  lastReceived <- newTVarIO ts
-  timeoutErrorCount <- newTVarIO 0
-  sndQ <- newTBQueueIO 100
-  rcvQ <- newTBQueueIO 100
+  connected <- newTVar False
+  clientCorrId <- C.newRandomDRG g
+  sentCommands <- TM.empty
+  sendPings <- newTVar False
+  lastReceived <- newTVar ts
+  timeoutErrorCount <- newTVar 0
+  sndQ <- newTBQueue 100
+  rcvQ <- newTBQueue 100
   return
     ProtocolClient
       { action = Nothing,
@@ -250,16 +244,6 @@ data SocksMode
     SMOnion
   deriving (Eq, Show)
 
-instance StrEncoding SocksMode where
-  strEncode = \case
-    SMAlways -> "always"
-    SMOnion -> "onion"
-  strP =
-    A.takeTill (== ' ') >>= \case
-      "always" -> pure SMAlways
-      "onion" -> pure SMOnion
-      _ -> fail "Invalid Socks mode"
-
 -- | network configuration for the client
 data NetworkConfig = NetworkConfig
   { -- | use SOCKS5 proxy
@@ -447,8 +431,7 @@ transportSession' = transportSession . client_
 type UserId = Int64
 
 -- | Transport session key - includes entity ID if `sessionMode = TSMEntity`.
--- Please note that for SMP connection ID is used as entity ID, not queue ID.
-type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
+type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
 
 -- | Connects to 'ProtocolServer' using passed client configuration
 -- and queue for messages and notifications.
@@ -459,21 +442,21 @@ getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> T
 getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
-      (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
+      (getCurrentTime >>= atomically . mkProtocolClient useHost >>= runClient useTransport useHost)
         `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
     Left e -> pure $ Left e
   where
     NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
-    mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
+    mkProtocolClient :: TransportHost -> UTCTime -> STM (PClient v err msg)
     mkProtocolClient transportHost ts = do
-      connected <- newTVarIO False
-      sendPings <- newTVarIO False
-      lastReceived <- newTVarIO ts
-      timeoutErrorCount <- newTVarIO 0
-      clientCorrId <- atomically $ C.newRandomDRG g
-      sentCommands <- TM.emptyIO
-      sndQ <- newTBQueueIO qSize
-      rcvQ <- newTBQueueIO qSize
+      connected <- newTVar False
+      sendPings <- newTVar False
+      lastReceived <- newTVar ts
+      timeoutErrorCount <- newTVar 0
+      clientCorrId <- C.newRandomDRG g
+      sentCommands <- TM.empty
+      sndQ <- newTBQueue qSize
+      rcvQ <- newTBQueue qSize
       return
         PClient
           { connected,
@@ -523,8 +506,9 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
           atomically $ do
             writeTVar (connected c) True
             putTMVar cVar $ Right c'
-          raceAny_ ([send c' th, process c', receive c' th] <> [monitor c' | smpPingInterval > 0])
-            `finally` disconnected c'
+          raceAny_ ([send c' th, process c', receive c' th] <> [monitor c' | smpPingInterval > 0]) `finally` do
+            atomically $ writeTVar (connected c) False
+            disconnected c'
 
     send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
     send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= sendPending
@@ -551,7 +535,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 NoEntity (protocolPing @v @err @msg)
+              whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing "" (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
@@ -572,7 +556,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
     processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
       | B.null $ bs corrId = sendMsg $ STEvent clientResp
       | otherwise =
-          TM.lookupIO corrId sentCommands >>= \case
+          atomically (TM.lookup corrId sentCommands) >>= \case
             Nothing -> sendMsg $ STUnexpectedError unexpected
             Just Request {entityId, command, pending, responseVar} -> do
               wasPending <-
@@ -677,7 +661,7 @@ createSMPQueue ::
   Bool ->
   ExceptT SMPClientError IO QueueIdsKeys
 createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
-  sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case
     IDS qik -> pure qik
     r -> throwE $ unexpectedResponse r
 
@@ -755,14 +739,9 @@ secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey
 {-# INLINE secureSndSMPQueue #-}
 
 proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) okResult
+proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
 {-# INLINE proxySecureSndSMPQueue #-}
 
-okResult :: BrokerMsg -> Maybe ()
-okResult = \case
-  OK -> Just ()
-  _ -> Nothing
-
 -- | Enable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
@@ -804,7 +783,7 @@ sendSMPMessage c spKey sId flags msg =
     r -> throwE $ unexpectedResponse r
 
 proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
-proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg) okResult
+proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg)
 
 -- | Acknowledge message delivery (server deletes the message).
 --
@@ -836,49 +815,12 @@ deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO
 deleteSMPQueues = okSMPCommands DEL
 {-# INLINE deleteSMPQueues #-}
 
-createSMPDataBlob :: SMPClient -> C.AAuthKeyPair -> BlobId -> DataBlob -> ExceptT SMPClientError IO ()
-createSMPDataBlob c (dKey, dpKey) dId blob = okSMPCommand (WRT dKey blob) c dpKey dId
-{-# INLINE createSMPDataBlob #-}
-
-deleteSMPDataBlob :: SMPClient -> DataPrivateAuthKey -> BlobId -> ExceptT SMPClientError IO ()
-deleteSMPDataBlob = okSMPCommand CLR
-{-# INLINE deleteSMPDataBlob #-}
-
--- pk is the private key passed to the client out of band.
--- Associated public key is used as ID to retrieve data blob
-getSMPDataBlob :: SMPClient -> C.PrivateKeyX25519 -> ExceptT SMPClientError IO DataBlob
-getSMPDataBlob c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} pk = do
-  serverKey <- case thAuth thParams of
-    Nothing -> throwE $ PCETransportError TENoServerAuth
-    Just THAuthClient {serverPeerPubKey = k} -> pure k
-  nonce <- liftIO . atomically $ C.randomCbNonce g
-  let dId = EntityId $ BA.convert $ C.pubKeyBytes $ C.publicKey pk
-  sendProtocolCommand_ c (Just nonce) Nothing Nothing dId (Cmd SSender READ) >>= \case
-    DATA encBlob -> decryptDataBlob serverKey pk nonce encBlob
-    r -> throwE $ unexpectedResponse r
-
-proxyGetSMPDataBlob :: SMPClient -> ProxiedRelay -> C.PrivateKeyX25519 -> ExceptT SMPClientError IO (Either ProxyClientError DataBlob)
-proxyGetSMPDataBlob c@ProtocolClient {client_ = PClient {clientCorrId = g}} proxiedRelay@ProxiedRelay {prServerKey} pk = do
-  nonce <- liftIO . atomically $ C.randomCbNonce g
-  let dId = EntityId $ BA.convert $ C.pubKeyBytes $ C.publicKey pk
-  encBlob_ <-
-    proxySMPCommand_ c (Just nonce) proxiedRelay Nothing dId READ $ \case
-      DATA encBlob -> Just encBlob
-      _ -> Nothing
-  bimapM pure (decryptDataBlob prServerKey pk nonce) encBlob_
-
-decryptDataBlob :: C.PublicKeyX25519 -> C.PrivateKeyX25519 -> C.CbNonce -> ByteString -> ExceptT (ProtocolClientError ErrorType) IO DataBlob
-decryptDataBlob serverKey pk nonce encBlob = do
-  let ss = C.dh' serverKey pk
-  blobStr <- liftEitherWith PCECryptoError $ C.cbDecrypt ss nonce encBlob
-  liftEitherWith (const $ PCEResponseError BLOCK) $ smpDecode blobStr
-
 -- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
 -- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
 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 NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
+      sendProtocolCommand_ c Nothing tOut Nothing "" (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
         PKEY sId vr (chain, key) ->
           case supportedClientSMPRelayVRange `compatibleVersion` vr of
             Nothing -> throwE $ transportErr TEVersion
@@ -926,9 +868,6 @@ instance StrEncoding ProxyClientError where
       "SYNTAX" -> ProxyResponseError <$> _strP
       _ -> fail "bad ProxyClientError"
 
-proxySMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> (BrokerMsg -> Maybe r) -> ExceptT SMPClientError IO (Either ProxyClientError r)
-proxySMPCommand c = proxySMPCommand_ c Nothing
-
 -- consider how to process slow responses - is it handled somehow locally or delegated to the caller
 -- this method is used in the client
 -- sends PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command Sender
@@ -956,25 +895,22 @@ proxySMPCommand c = proxySMPCommand_ c Nothing
 -- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
 
 -- This function proxies Sender commands that return OK or ERR
-proxySMPCommand_ ::
+proxySMPCommand ::
   SMPClient ->
-  -- optional correlation ID/nonce for the sending client
-  Maybe C.CbNonce ->
   -- proxy session from PKEY
   ProxiedRelay ->
-  -- command to deliver
+  -- message to deliver
   Maybe SndPrivateAuthKey ->
   SenderId ->
   Command 'Sender ->
-  (BrokerMsg -> Maybe r) ->
-  ExceptT SMPClientError IO (Either ProxyClientError r)
-proxySMPCommand_ c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nonce_ (ProxiedRelay sessionId v _ serverKey) spKey sId command toResult = do
+  ExceptT SMPClientError IO (Either ProxyClientError ())
+proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
   -- prepare params
   let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
       serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
   (cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g
   let cmdSecret = C.dh' serverKey cmdPrivKey
-  nonce@(C.CbNonce corrId) <- liftIO $ maybe (atomically $ C.randomCbNonce g) pure nonce_
+  nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
   -- encode
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command)
   auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
@@ -986,7 +922,7 @@ proxySMPCommand_ c@ProtocolClient {thParams = proxyThParams, client_ = PClient {
   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 (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
+  tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
     Right r -> case r of
       PRES (EncResponse er) -> do
         -- server interaction errors are thrown directly
@@ -994,11 +930,9 @@ proxySMPCommand_ c@ProtocolClient {thParams = proxyThParams, client_ = PClient {
         case tParse serverThParams t' of
           t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
             (_auth, _signed, (_c, _e, cmd)) -> case cmd of
-              Right r' -> case toResult r' of
-                Just r'' -> pure $ Right r''
-                Nothing -> case r' of
-                  ERR e -> throwE $ PCEProtocolError e -- this is the error from the destination relay
-                  _ -> throwE $ unexpectedResponse r'
+              Right OK -> pure $ Right ()
+              Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
+              Right r' -> throwE $ unexpectedResponse r'
               Left e -> throwE $ PCEResponseError e
           _ -> throwE $ PCETransportError TEBadBlock
       ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left
@@ -1024,7 +958,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 NoEntity (Cmd SSender (RFWD eft)) >>= \case
+  sendProtocolCommand_ c (Just nonce) Nothing Nothing "" (Cmd SSender (RFWD eft)) >>= \case
     RRES (EncFwdResponse efr) -> do
       -- unwrap
       r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
@@ -1072,7 +1006,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 NoEntity $ Left $ PCETransportError TEBadBlock)
+          pure $ L.fromList $ rs <> replicate diff (Response "" $ Left $ PCETransportError TEBadBlock)
       | otherwise = do
           putStrLn "send error: more responses than expected"
           pure $ L.fromList $ take (L.length cs) rs
@@ -1146,13 +1080,13 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC
   nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_
   let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command)
       auth = authTransmission (thAuth thParams) pKey_ nonce tForAuth
-  r <- mkRequest (CorrId corrId)
+  r <- atomically $ mkRequest (CorrId corrId)
   pure ((,tToSend) <$> auth, r)
   where
-    mkRequest :: CorrId -> IO (Request err msg)
+    mkRequest :: CorrId -> STM (Request err msg)
     mkRequest corrId = do
-      pending <- newTVarIO True
-      responseVar <- newEmptyTMVarIO
+      pending <- newTVar True
+      responseVar <- newEmptyTMVar
       let r =
             Request
               { corrId,
@@ -1161,7 +1095,7 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC
                 pending,
                 responseVar
               }
-      atomically $ TM.insert corrId r sentCommands
+      TM.insert corrId r sentCommands
       pure r
 
 authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TransmissionAuth)

src/Simplex/Messaging/Client/Agent.hs

@@ -100,7 +100,7 @@ data SMPClientAgent = SMPClientAgent
     randomDrg :: TVar ChaChaDRG,
     smpClients :: TMap SMPServer SMPClientVar,
     smpSessions :: TMap SessionId (OwnServer, SMPClient),
-    srvSubs :: TMap SMPServer (TMap SMPSub (SessionId, C.APrivateAuthKey)),
+    srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
     pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
     smpSubWorkers :: TMap SMPServer (SessionVar (Async ())),
     workerSeq :: TVar Int
@@ -108,17 +108,17 @@ data SMPClientAgent = SMPClientAgent
 
 type OwnServer = Bool
 
-newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
+newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent
 newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
-  active <- newTVarIO True
-  msgQ <- newTBQueueIO msgQSize
-  agentQ <- newTBQueueIO agentQSize
-  smpClients <- TM.emptyIO
-  smpSessions <- TM.emptyIO
-  srvSubs <- TM.emptyIO
-  pendingSrvSubs <- TM.emptyIO
-  smpSubWorkers <- TM.emptyIO
-  workerSeq <- newTVarIO 0
+  active <- newTVar True
+  msgQ <- newTBQueue msgQSize
+  agentQ <- newTBQueue agentQSize
+  smpClients <- TM.empty
+  smpSessions <- TM.empty
+  srvSubs <- TM.empty
+  pendingSrvSubs <- TM.empty
+  smpSubWorkers <- TM.empty
+  workerSeq <- newTVar 0
   pure
     SMPClientAgent
       { agentCfg,
@@ -204,17 +204,14 @@ connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, random
 
     removeClientAndSubs :: SMPClient -> IO (Maybe (Map SMPSub C.APrivateAuthKey))
     removeClientAndSubs smp = atomically $ do
-      TM.delete sessId smpSessions
       removeSessVar v srv smpClients
-      TM.lookup srv (srvSubs ca) >>= mapM updateSubs
+      TM.delete (sessionId $ thParams smp) smpSessions
+      TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
       where
-        sessId = sessionId $ thParams smp
         updateSubs sVar = do
-          -- removing subscriptions that have matching sessionId to disconnected client
-          -- and keep the other ones (they can be made by the new client)
-          pending <- M.map snd <$> stateTVar sVar (M.partition ((sessId ==) . fst))
-          addSubs_ (pendingSrvSubs ca) srv pending
-          pure pending
+          ss <- readTVar sVar
+          addSubs_ (pendingSrvSubs ca) srv ss
+          pure ss
 
     serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
     serverDown ss = unless (M.null ss) $ do
@@ -229,7 +226,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
   where
     getWorkerVar ts =
       ifM
-        (noPending)
+        (null <$> getPending)
         (pure Nothing) -- prevent race with cleanup and adding pending queues in another call
         (Just <$> getSessVar workerSeq srv smpSubWorkers ts)
     newSubWorker :: SessionVar (Async ()) -> IO ()
@@ -238,13 +235,12 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
       atomically $ putTMVar (sessionVar v) a
     runSubWorker =
       withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
-        pending <- liftIO getPending
+        pending <- atomically getPending
         unless (null pending) $ whenM (readTVarIO active) $ do
           void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending)
           loop
     ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-    noPending = maybe (pure True) (fmap M.null . readTVar) =<< TM.lookup srv (pendingSrvSubs ca)
-    getPending = maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (pendingSrvSubs ca)
+    getPending = maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
     cleanup :: SessionVar (Async ()) -> STM ()
     cleanup v = do
       -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
@@ -255,14 +251,14 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
 reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO ()
 reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs =
   withSMP ca srv $ \smp -> liftIO $ do
-    currSubs <- maybe (pure M.empty) readTVarIO =<< TM.lookupIO srv (srvSubs ca)
+    currSubs <- atomically $ maybe (pure M.empty) readTVar =<< TM.lookup srv (srvSubs ca)
     let (nSubs, rSubs) = foldr (groupSub currSubs) ([], []) $ M.assocs cs
     subscribe_ smp SPNotifier nSubs
     subscribe_ smp SPRecipient rSubs
   where
-    groupSub :: Map SMPSub (SessionId, C.APrivateAuthKey) -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)])
-    groupSub currSubs (s@(party, qId), k) acc@(nSubs, rSubs)
-      | M.member s currSubs = acc
+    groupSub :: Map SMPSub C.APrivateAuthKey -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)])
+    groupSub currSubs (s@(party, qId), k) (nSubs, rSubs)
+      | M.member s currSubs = (nSubs, rSubs)
       | otherwise = case party of
           SPNotifier -> (s' : nSubs, rSubs)
           SPRecipient -> (nSubs, s' : rSubs)
@@ -290,8 +286,8 @@ getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
             (Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection
             (pure $ Just $ Left e) -- not expired, returning error
 
-lookupSMPServerClient :: SMPClientAgent -> SessionId -> IO (Maybe (OwnServer, SMPClient))
-lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookupIO sessId smpSessions
+lookupSMPServerClient :: SMPClientAgent -> SessionId -> STM (Maybe (OwnServer, SMPClient))
+lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookup sessId smpSessions
 
 closeSMPClientAgent :: SMPClientAgent -> IO ()
 closeSMPClientAgent c = do
@@ -350,18 +346,17 @@ smpSubscribeQueues party ca smp srv subs = do
       when tempErrs $ reconnectClient ca srv
     Nothing -> reconnectClient ca srv
   where
-    processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
+    processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId])
     processSubscriptions rs = do
       pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
       let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs)
       unless (null oks) $ addSubscriptions ca srv party oks
       unless (null notPending) $ removePendingSubs ca srv party notPending
       pure acc
-    sessId = sessionId $ thParams smp
-    groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, (SessionId, C.APrivateAuthKey))], [QueueId])
-    groupSub pending ((qId, pk), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of
+    groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId])
+    groupSub pending (s@(qId, _), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of
       Right ()
-        | M.member (party, qId) pending -> (tempErrs, finalErrs, (qId, (sessId, pk)) : oks, qId : notPending)
+        | M.member (party, qId) pending -> (tempErrs, finalErrs, s : oks, qId : notPending)
         | otherwise -> acc
       Left e
         | temporaryClientError e -> (True, finalErrs, oks, notPending)
@@ -372,21 +367,19 @@ 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 -> SessionId -> SMPServer -> STM Bool
-activeClientSession' ca sessId srv = sameSess <$> tryReadSessVar srv (smpClients ca)
-  where
-    sameSess = \case
-      Just (Right (_, smp')) -> sessId == sessionId (thParams smp')
-      _ -> False
-
 activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
-activeClientSession ca = activeClientSession' ca . sessionId . thParams
+activeClientSession ca smp srv = sameSess <$> tryReadSessVar srv (smpClients ca)
+  where
+    sessId = sessionId . thParams
+    sameSess = \case
+      Just (Right (_, smp')) -> sessId smp == sessId smp'
+      _ -> False
 
 showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)
 
-addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, (SessionId, C.APrivateAuthKey))] -> STM ()
+addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
 addSubscriptions = addSubsList_ . srvSubs
 {-# INLINE addSubscriptions #-}
 
@@ -394,12 +387,12 @@ addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APr
 addPendingSubs = addSubsList_ . pendingSrvSubs
 {-# INLINE addPendingSubs #-}
 
-addSubsList_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSubParty -> [(QueueId, s)] -> STM ()
+addSubsList_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
 addSubsList_ subs srv party ss = addSubs_ subs srv ss'
   where
     ss' = M.fromList $ map (first (party,)) ss
 
-addSubs_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> Map SMPSub s -> STM ()
+addSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> Map SMPSub C.APrivateAuthKey -> STM ()
 addSubs_ subs srv ss =
   TM.lookup srv subs >>= \case
     Just m -> TM.union ss m
@@ -409,7 +402,7 @@ removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
 removeSubscription = removeSub_ . srvSubs
 {-# INLINE removeSubscription #-}
 
-removeSub_ :: TMap SMPServer (TMap SMPSub s) -> SMPServer -> SMPSub -> STM ()
+removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM ()
 removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
 
 removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()

src/Simplex/Messaging/Crypto/SNTRUP761.hs

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

src/Simplex/Messaging/Encoding.hs

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

src/Simplex/Messaging/Encoding/String.hs

@@ -28,8 +28,6 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
 import Data.Int (Int64)
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IS
 import qualified Data.List.NonEmpty as L
 import Data.Set (Set)
 import qualified Data.Set as S
@@ -41,7 +39,7 @@ import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.Util ((<$?>))
 
 class TextEncoding a where
   textEncode :: a -> Text
@@ -55,20 +53,14 @@ 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
@@ -127,15 +119,15 @@ instance StrEncoding Bool where
   {-# INLINE strP #-}
 
 instance StrEncoding Int where
-  strEncode = bshow
+  strEncode = B.pack . show
   {-# INLINE strEncode #-}
-  strP = A.signed A.decimal
+  strP = A.decimal
   {-# INLINE strP #-}
 
 instance StrEncoding Int64 where
-  strEncode = bshow
+  strEncode = B.pack . show
   {-# INLINE strEncode #-}
-  strP = A.signed A.decimal
+  strP = A.decimal
   {-# INLINE strP #-}
 
 instance StrEncoding SystemTime where
@@ -162,10 +154,6 @@ instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
   strEncode = strEncodeList . S.toList
   strP = S.fromList <$> listItem `A.sepBy'` A.char ','
 
-instance StrEncoding IntSet where
-  strEncode = strEncodeList . IS.toList
-  strP = IS.fromList <$> listItem `A.sepBy'` A.char ','
-
 listItem :: StrEncoding a => Parser a
 listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
 

src/Simplex/Messaging/Notifications/Client.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Messaging.Notifications.Client where
 
@@ -12,7 +11,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, pattern NoEntity)
+import Simplex.Messaging.Protocol (ErrorType)
 
 type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
 
@@ -23,7 +22,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) NoEntity (TNEW newTkn) >>= \case
+  sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
     r -> throwE $ unexpectedResponse r
 
@@ -47,7 +46,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) NoEntity (SNEW newSub) >>= \case
+  sendNtfCommand c (Just pKey) "" (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 entityId, _) cmd = case cmd of
+  checkCredentials (auth, _, 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 (_, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials (_, _, 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 = EntityId
+type NtfEntityId = ByteString
 
 type NtfSubscriptionId = NtfEntityId
 

src/Simplex/Messaging/Notifications/Server.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -20,7 +19,6 @@ 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 (..))
@@ -32,7 +30,6 @@ 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
@@ -45,7 +42,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 (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, encodeTransmission, tGet, tPut)
+import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Stats
@@ -121,16 +118,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
           hSetBuffering h LineBuffering
           ts <- getCurrentTime
-          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
+          fromTime' <- atomically $ swapTVar fromTime ts
+          tknCreated' <- atomically $ swapTVar tknCreated 0
+          tknVerified' <- atomically $ swapTVar tknVerified 0
+          tknDeleted' <- atomically $ swapTVar tknDeleted 0
+          subCreated' <- atomically $ swapTVar subCreated 0
+          subDeleted' <- atomically $ swapTVar subDeleted 0
+          ntfReceived' <- atomically $ swapTVar ntfReceived 0
+          ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
+          tkn <- atomically $ periodStatCounts activeTokens ts
+          sub <- atomically $ periodStatCounts activeSubs ts
           hPutStrLn h $
             intercalate
               ","
@@ -179,10 +176,10 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
     getSMPSubscriber :: SMPServer -> M SMPSubscriber
     getSMPSubscriber smpServer =
-      liftIO (TM.lookupIO smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
+      atomically (TM.lookup smpServer smpSubscribers) >>= maybe createSMPSubscriber pure
       where
         createSMPSubscriber = do
-          sub@SMPSubscriber {subThreadId} <- liftIO newSMPSubscriber
+          sub@SMPSubscriber {subThreadId} <- atomically newSMPSubscriber
           atomically $ TM.insert smpServer sub smpSubscribers
           tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber sub)
           atomically . writeTVar subThreadId $ Just tId
@@ -206,7 +203,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
     receiveSMP :: M ()
     receiveSMP = forever $ do
-      ((_, srv, _), _thVersion, sessionId, ts) <- atomically $ readTBQueue msgQ
+      ((_, srv, _), _, _, 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
@@ -218,14 +215,12 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
               st <- asks store
               NtfPushServer {pushQ} <- asks pushServer
               stats <- asks serverStats
-              liftIO $ updatePeriodStats (activeSubs stats) ntfId
+              atomically $ updatePeriodStats (activeSubs stats) ntfId
               atomically $
                 findNtfSubscriptionToken st smpQueue
-                  >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| [])))
+                  >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
               incNtfStat ntfReceived
-            Right SMP.END ->
-              whenM (atomically $ activeClientSession' ca sessionId srv) $
-                updateSubStatus smpQueue NSEnd
+            Right SMP.END -> 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
@@ -302,7 +297,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
       void $ deliverNotification pp tkn ntf
     PNMessage {} -> checkActiveTkn status $ do
       stats <- asks serverStats
-      liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
+      atomically $ updatePeriodStats (activeTokens stats) ntfTknId
       void $ deliverNotification pp tkn ntf
       incNtfStat ntfDelivered
   where
@@ -338,7 +333,7 @@ runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
 runNtfClientTransport th@THandle {params} = do
   qSize <- asks $ clientQSize . config
   ts <- liftIO getSystemTime
-  c <- liftIO $ newNtfServerClient qSize params ts
+  c <- atomically $ newNtfServerClient qSize params ts
   s <- asks subscriber
   ps <- asks pushServer
   expCfg <- asks $ inactiveClientExpiration . config
@@ -449,7 +444,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
         withNtfLog (`logCreateToken` tkn)
         incNtfStatT token tknCreated
-        pure (corrId, NoEntity, NRTknId tknId srvDhPubKey)
+        pure (corrId, "", 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
@@ -512,7 +507,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             | otherwise -> do
                 logDebug "TCRN"
                 atomically $ writeTVar tknCronInterval int
-                liftIO (TM.lookupIO tknId intervalNotifiers) >>= \case
+                atomically (TM.lookup tknId intervalNotifiers) >>= \case
                   Nothing -> runIntervalNotifier int
                   Just IntervalNotifier {interval, action} ->
                     unless (interval == int) $ do
@@ -540,7 +535,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
             _ -> pure $ NRErr AUTH
         withNtfLog (`logCreateSubscription` sub)
         incNtfStat subCreated
-        pure (corrId, NoEntity, resp)
+        pure (corrId, "", resp)
       NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
         status <- readTVarIO subStatus
         (corrId,subId,) <$> case cmd of
@@ -565,7 +560,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
           PING -> pure NRPong
       NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
     getId :: M NtfEntityId
-    getId = fmap EntityId . randomBytes =<< asks (subIdBytes . config)
+    getId = randomBytes =<< asks (subIdBytes . config)
     getRegCode :: M NtfRegCode
     getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config))
     randomBytes :: Int -> M ByteString
@@ -578,19 +573,19 @@ 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 -> IORef Int) -> M ()
+incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M ()
 incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
 incNtfStatT _ statSel = incNtfStat statSel
 
-incNtfStat :: (NtfServerStats -> IORef Int) -> M ()
+incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
 incNtfStat statSel = do
   stats <- asks serverStats
-  liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
+  atomically $ modifyTVar' (statSel stats) (+ 1)
 
 saveServerStats :: M ()
 saveServerStats =
   asks (serverStatsBackupFile . config)
-    >>= mapM_ (\f -> asks serverStats >>= liftIO . getNtfServerStatsData >>= liftIO . saveStats f)
+    >>= mapM_ (\f -> asks serverStats >>= atomically . getNtfServerStatsData >>= liftIO . saveStats f)
   where
     saveStats f stats = do
       logInfo $ "saving server stats to file " <> T.pack f
@@ -605,7 +600,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d -> do
           s <- asks serverStats
-          liftIO $ setNtfServerStats s d
+          atomically $ setNtfServerStats s d
           renameFile f $ f <> ".bak"
           logInfo "server stats restored"
         Left e -> do

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

@@ -10,6 +10,7 @@ module Simplex.Messaging.Notifications.Server.Env where
 import Control.Concurrent (ThreadId)
 import Control.Concurrent.Async (Async)
 import Control.Logger.Simple
+import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
@@ -84,16 +85,16 @@ data NtfEnv = NtfEnv
 
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
 newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
-  random <- C.newRandom
-  store <- newNtfStore
+  random <- liftIO C.newRandom
+  store <- atomically newNtfStore
   logInfo "restoring subscriptions..."
-  storeLog <- mapM (`readWriteNtfStore` store) storeLogFile
+  storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
   logInfo "restored subscriptions"
-  subscriber <- newNtfSubscriber subQSize smpAgentCfg random
-  pushServer <- newNtfPushServer pushQSize apnsConfig
-  tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
-  Fingerprint fp <- loadFingerprint caCertificateFile
-  serverStats <- newNtfServerStats =<< getCurrentTime
+  subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random
+  pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
+  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
+  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
+  serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
   pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
 data NtfSubscriber = NtfSubscriber
@@ -102,10 +103,10 @@ data NtfSubscriber = NtfSubscriber
     smpAgent :: SMPClientAgent
   }
 
-newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber
+newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> STM NtfSubscriber
 newNtfSubscriber qSize smpAgentCfg random = do
-  smpSubscribers <- TM.emptyIO
-  newSubQ <- newTBQueueIO qSize
+  smpSubscribers <- TM.empty
+  newSubQ <- newTBQueue qSize
   smpAgent <- newSMPClientAgent smpAgentCfg random
   pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
 
@@ -114,10 +115,10 @@ data SMPSubscriber = SMPSubscriber
     subThreadId :: TVar (Maybe (Weak ThreadId))
   }
 
-newSMPSubscriber :: IO SMPSubscriber
+newSMPSubscriber :: STM SMPSubscriber
 newSMPSubscriber = do
-  newSubQ <- newTQueueIO
-  subThreadId <- newTVarIO Nothing
+  newSubQ <- newTQueue
+  subThreadId <- newTVar Nothing
   pure SMPSubscriber {newSubQ, subThreadId}
 
 data NtfPushServer = NtfPushServer
@@ -133,11 +134,11 @@ data IntervalNotifier = IntervalNotifier
     interval :: Word16
   }
 
-newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
+newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer
 newNtfPushServer qSize apnsConfig = do
-  pushQ <- newTBQueueIO qSize
-  pushClients <- TM.emptyIO
-  intervalNotifiers <- TM.emptyIO
+  pushQ <- newTBQueue qSize
+  pushClients <- TM.empty
+  intervalNotifiers <- TM.empty
   pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
@@ -150,7 +151,7 @@ newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
 
 getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 getPushClient s@NtfPushServer {pushClients} pp =
-  TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure
+  atomically (TM.lookup pp pushClients) >>= maybe (newPushClient s pp) pure
 
 data NtfRequest
   = NtfReqNew CorrId ANewNtfEntity
@@ -166,11 +167,11 @@ data NtfServerClient = NtfServerClient
     sndActiveAt :: TVar SystemTime
   }
 
-newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> IO NtfServerClient
+newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> STM NtfServerClient
 newNtfServerClient qSize ntfThParams ts = do
-  rcvQ <- newTBQueueIO qSize
-  sndQ <- newTBQueueIO qSize
-  connected <- newTVarIO True
-  rcvActiveAt <- newTVarIO ts
-  sndActiveAt <- newTVarIO ts
+  rcvQ <- newTBQueue qSize
+  sndQ <- newTBQueue qSize
+  connected <- newTVar True
+  rcvActiveAt <- newTVar ts
+  sndActiveAt <- newTVar ts
   return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt}

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

@@ -1,7 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -133,8 +132,7 @@ 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,
-                                smpPingInterval = 60_000_000 -- 1 minutes
+                                socksMode = either (const SMOnion) textToSocksMode $ lookupValue "SUBSCRIBER" "socks_mode" ini
                               }
                         },
                     persistErrorInterval = 0 -- seconds

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

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

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

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

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

@@ -33,13 +33,13 @@ data NtfStore = NtfStore
     subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId
   }
 
-newNtfStore :: IO NtfStore
+newNtfStore :: STM NtfStore
 newNtfStore = do
-  tokens <- TM.emptyIO
-  tokenRegistrations <- TM.emptyIO
-  subscriptions <- TM.emptyIO
-  tokenSubscriptions <- TM.emptyIO
-  subscriptionLookup <- TM.emptyIO
+  tokens <- TM.empty
+  tokenRegistrations <- TM.empty
+  subscriptions <- TM.empty
+  tokenSubscriptions <- TM.empty
+  subscriptionLookup <- TM.empty
   pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup}
 
 data NtfTknData = NtfTknData
@@ -77,9 +77,6 @@ data NtfEntityRec (e :: NtfEntity) where
 getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe NtfTknData)
 getNtfToken st tknId = TM.lookup tknId (tokens st)
 
-getNtfTokenIO :: NtfStore -> NtfTokenId -> IO (Maybe NtfTknData)
-getNtfTokenIO st tknId = TM.lookupIO tknId (tokens st)
-
 addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
 addNtfToken st tknId tkn@NtfTknData {token, tknVerifyKey} = do
   TM.insert tknId tkn $ tokens st

src/Simplex/Messaging/Notifications/Types.hs

@@ -11,7 +11,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (UTCTime)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..), UserId)
+import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
@@ -48,7 +48,6 @@ data NtfToken = NtfToken
     ntfServer :: NtfServer,
     ntfTokenId :: Maybe NtfTokenId,
     -- TODO combine keys to key pair as the types should match
-
     -- | key used by the ntf server to verify transmissions
     ntfPubKey :: C.APublicAuthKey,
     -- | key used by the ntf client to sign transmissions
@@ -80,17 +79,17 @@ newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
       ntfMode
     }
 
-data NtfSubAction = NSANtf NtfSubNTFAction | NSASMP NtfSubSMPAction
+data NtfSubAction = NtfSubNTFAction NtfSubNTFAction | NtfSubSMPAction NtfSubSMPAction
   deriving (Show)
 
 isDeleteNtfSubAction :: NtfSubAction -> Bool
 isDeleteNtfSubAction = \case
-  NSANtf a -> case a of
+  NtfSubNTFAction a -> case a of
     NSACreate -> False
     NSACheck -> False
     NSADelete -> True
     NSARotate -> True
-  NSASMP a -> case a of
+  NtfSubSMPAction a -> case a of
     NSASmpKey -> False
     NSASmpDelete -> True
 
@@ -178,8 +177,7 @@ instance FromField NtfAgentSubStatus where fromField = fromTextField_ $ either (
 instance ToField NtfAgentSubStatus where toField = toField . decodeLatin1 . smpEncode
 
 data NtfSubscription = NtfSubscription
-  { userId :: UserId,
-    connId :: ConnId,
+  { connId :: ConnId,
     smpServer :: SMPServer,
     ntfQueueId :: Maybe NotifierId,
     ntfServer :: NtfServer,
@@ -188,11 +186,10 @@ data NtfSubscription = NtfSubscription
   }
   deriving (Show)
 
-newNtfSubscription :: UserId -> ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> NtfSubscription
-newNtfSubscription userId connId smpServer ntfQueueId ntfServer ntfSubStatus =
+newNtfSubscription :: ConnId -> SMPServer -> Maybe NotifierId -> NtfServer -> NtfAgentSubStatus -> NtfSubscription
+newNtfSubscription connId smpServer ntfQueueId ntfServer ntfSubStatus =
   NtfSubscription
-    { userId,
-      connId,
+    { connId,
       smpServer,
       ntfQueueId,
       ntfServer,

src/Simplex/Messaging/Protocol.hs

@@ -2,13 +2,11 @@
 {-# 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 #-}
@@ -101,10 +99,8 @@ module Simplex.Messaging.Protocol
     BasicAuth (..),
     SrvLoc (..),
     CorrId (..),
-    EntityId (..),
-    pattern NoEntity,
+    EntityId,
     QueueId,
-    BlobId,
     RecipientId,
     SenderId,
     NotifierId,
@@ -118,8 +114,6 @@ module Simplex.Messaging.Protocol
     NtfPublicAuthKey,
     RcvNtfPublicDhKey,
     RcvNtfDhSecret,
-    DataPrivateAuthKey,
-    DataPublicAuthKey,
     Message (..),
     RcvMessage (..),
     MsgId,
@@ -139,8 +133,6 @@ module Simplex.Messaging.Protocol
     FwdResponse (..),
     FwdTransmission (..),
     MsgFlags (..),
-    DataBlob (..),
-    EncDataBlob,
     initialSMPClientVersion,
     currentSMPClientVersion,
     userProtocol,
@@ -337,8 +329,8 @@ data RawTransmission = RawTransmission
   { authenticator :: ByteString, -- signature or encrypted transmission hash
     authorized :: ByteString, -- authorized transmission
     sessId :: SessionId,
-    corrId :: CorrId,
-    entityId :: EntityId,
+    corrId :: ByteString,
+    entityId :: ByteString,
     command :: ByteString
   }
   deriving (Show)
@@ -365,7 +357,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, CorrId, EntityId, ByteString)
+type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString)
 
 -- | unparsed sent SMP transmission with signature.
 type SentRawTransmission = (Maybe TransmissionAuth, ByteString)
@@ -382,15 +374,7 @@ type NotifierId = QueueId
 -- | SMP queue ID on the server.
 type QueueId = EntityId
 
-type BlobId = EntityId
-
--- 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 ""
+type EntityId = ByteString
 
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
@@ -411,10 +395,6 @@ data Command (p :: Party) where
   OFF :: Command Recipient
   DEL :: Command Recipient
   QUE :: Command Recipient
-  -- Data storage commands
-  WRT :: DataPublicAuthKey -> DataBlob -> Command Recipient
-  CLR :: Command Recipient
-  READ :: Command Sender
   -- SMP sender commands
   SKEY :: SndPublicAuthKey -> Command Sender
   -- SEND v1 has to be supported for encoding/decoding
@@ -423,7 +403,6 @@ data Command (p :: Party) where
   PING :: Command Sender
   -- SMP notification subscriber commands
   NSUB :: Command Notifier
-  -- Proxy commands
   PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI
   -- Transmission to proxy:
   -- - entity ID: ID of the session with relay returned in PKEY (response to PRXY)
@@ -497,7 +476,6 @@ data BrokerMsg where
   PRES :: EncResponse -> BrokerMsg -- proxy to client
   END :: BrokerMsg
   INFO :: QueueInfo -> BrokerMsg
-  DATA :: EncDataBlob -> BrokerMsg
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
   PONG :: BrokerMsg
@@ -695,9 +673,6 @@ data CommandTag (p :: Party) where
   OFF_ :: CommandTag Recipient
   DEL_ :: CommandTag Recipient
   QUE_ :: CommandTag Recipient
-  WRT_ :: CommandTag Recipient
-  CLR_ :: CommandTag Recipient
-  READ_ :: CommandTag Sender
   SKEY_ :: CommandTag Sender
   SEND_ :: CommandTag Sender
   PING_ :: CommandTag Sender
@@ -722,7 +697,6 @@ data BrokerMsgTag
   | PRES_
   | END_
   | INFO_
-  | DATA_
   | OK_
   | ERR_
   | PONG_
@@ -748,9 +722,6 @@ instance PartyI p => Encoding (CommandTag p) where
     OFF_ -> "OFF"
     DEL_ -> "DEL"
     QUE_ -> "QUE"
-    WRT_ -> "WRT"
-    CLR_ -> "CLR"
-    READ_ -> "READ"
     SKEY_ -> "SKEY"
     SEND_ -> "SEND"
     PING_ -> "PING"
@@ -772,9 +743,6 @@ instance ProtocolMsgTag CmdTag where
     "OFF" -> Just $ CT SRecipient OFF_
     "DEL" -> Just $ CT SRecipient DEL_
     "QUE" -> Just $ CT SRecipient QUE_
-    "WRT" -> Just $ CT SRecipient WRT_
-    "CLR" -> Just $ CT SRecipient CLR_
-    "READ" -> Just $ CT SSender READ_
     "SKEY" -> Just $ CT SSender SKEY_
     "SEND" -> Just $ CT SSender SEND_
     "PING" -> Just $ CT SSender PING_
@@ -802,7 +770,6 @@ instance Encoding BrokerMsgTag where
     PRES_ -> "PRES"
     END_ -> "END"
     INFO_ -> "INFO"
-    DATA_ -> "DATA"
     OK_ -> "OK"
     ERR_ -> "ERR"
     PONG_ -> "PONG"
@@ -819,7 +786,6 @@ instance ProtocolMsgTag BrokerMsgTag where
     "PRES" -> Just PRES_
     "END" -> Just END_
     "INFO" -> Just INFO_
-    "DATA" -> Just DATA_
     "OK" -> Just OK_
     "ERR" -> Just ERR_
     "PONG" -> Just PONG_
@@ -1131,13 +1097,10 @@ serverStrP = do
     portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
 -- | Transmission correlation ID.
-newtype CorrId = CorrId {bs :: ByteString}
-  deriving (Eq, Ord, Show)
-  deriving newtype (Encoding)
+newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
 
 instance IsString CorrId where
   fromString = CorrId . fromString
-  {-# INLINE fromString #-}
 
 instance StrEncoding CorrId where
   strEncode (CorrId cId) = strEncode cId
@@ -1194,38 +1157,12 @@ type RcvNtfPublicDhKey = C.PublicKeyX25519
 -- | DH Secret used to encrypt notification metadata from server to recipient
 type RcvNtfDhSecret = C.DhSecretX25519
 
--- | private key to authorize owner access to data blobs
-type DataPrivateAuthKey = C.APrivateAuthKey
-
--- | public key to authorize owner access to data blobs
-type DataPublicAuthKey = C.APublicAuthKey
-
 -- | SMP message server ID.
 type MsgId = ByteString
 
 -- | SMP message body.
 type MsgBody = ByteString
 
-data DataBlob = DataBlob
-  { dataNonce :: C.CbNonce,
-    dataBody :: ByteString
-  }
-  deriving (Eq, Show)
-
-instance Encoding DataBlob where
-  smpEncode DataBlob {dataNonce, dataBody} = smpEncode (dataNonce, Tail dataBody)
-  smpP = do
-    (dataNonce, Tail dataBody) <- smpP
-    pure DataBlob {dataNonce, dataBody}
-
-instance StrEncoding DataBlob where
-  strEncode DataBlob {dataNonce, dataBody} = strEncode (dataNonce, dataBody)
-  strP = do
-    (dataNonce, dataBody) <- strP
-    pure DataBlob {dataNonce, dataBody}
-
-type EncDataBlob = ByteString
-
 data ProtocolErrorType = PECmdSyntax | PECmdUnknown | PESession | PEBlock
 
 -- | Type for protocol errors.
@@ -1370,9 +1307,6 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     OFF -> e OFF_
     DEL -> e DEL_
     QUE -> e QUE_
-    WRT k blob -> e (WRT_, ' ', k, blob)
-    CLR -> e CLR_
-    READ -> e READ_
     SKEY k -> e (SKEY_, ' ', k)
     SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
     PING -> e PING_
@@ -1389,7 +1323,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (auth, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials (auth, _, entId, _) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
     NEW {}
       | isNothing auth -> Left $ CMD NO_AUTH
@@ -1402,12 +1336,14 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     SKEY _
       | isNothing auth || B.null entId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
-    READ -> entityNoAuthCmd
     PING -> noAuthCmd
     PRXY {} -> noAuthCmd
-    PFWD {} -> entityNoAuthCmd
+    PFWD {}
+      | B.null entId -> Left $ CMD NO_ENTITY
+      | isNothing auth -> Right cmd
+      | otherwise -> Left $ CMD HAS_AUTH
     RFWD _ -> noAuthCmd
-    -- other client commands must have both signature and entity ID
+    -- other client commands must have both signature and queue ID
     _
       | isNothing auth || B.null entId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
@@ -1417,11 +1353,6 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
       noAuthCmd
         | isNothing auth && B.null entId = Right cmd
         | otherwise = Left $ CMD HAS_AUTH
-      entityNoAuthCmd :: Either ErrorType (Command p)
-      entityNoAuthCmd
-        | B.null entId = Left $ CMD NO_ENTITY
-        | isJust auth = Left $ CMD HAS_AUTH
-        | otherwise = Right cmd
 
 instance ProtocolEncoding SMPVersion ErrorType Cmd where
   type Tag Cmd = CmdTag
@@ -1447,13 +1378,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
         OFF_ -> pure OFF
         DEL_ -> pure DEL
         QUE_ -> pure QUE
-        WRT_ -> WRT <$> _smpP <*> smpP
-        CLR_ -> pure CLR
     CT SSender tag ->
       Cmd SSender <$> case tag of
         SKEY_ -> SKEY <$> _smpP
         SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
-        READ_ -> pure READ
         PING_ -> pure PING
         RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
     CT SProxiedClient tag ->
@@ -1484,7 +1412,6 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
     END -> e END_
     INFO info -> e (INFO_, ' ', info)
-    DATA body -> e (DATA_, ' ', Tail body)
     OK -> e OK_
     ERR err -> e (ERR_, ' ', err)
     PONG -> e PONG_
@@ -1510,7 +1437,6 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
     END_ -> pure END
     INFO_ -> INFO <$> _smpP
-    DATA_ -> DATA . unTail <$> _smpP
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP
     PONG_ -> pure PONG
@@ -1522,7 +1448,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     PEBlock -> BLOCK
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials (_, _, entId, _) cmd = case cmd of
     -- IDS response should not have queue ID
     IDS _ -> Right cmd
     -- ERR response does not always have queue ID
@@ -1795,16 +1721,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, NoEntity, Left $ fromProtocolError @v @err @cmd PESession))
+    | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PESession))
   Left _ -> tError ""
   where
-    tError :: CorrId -> SignedTransmission err cmd
-    tError corrId = (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PEBlock))
+    tError :: ByteString -> SignedTransmission err cmd
+    tError corrId = (Nothing, "", (CorrId corrId, "", 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, entityId, cmd))
+       in (sig, signed, (CorrId corrId, entityId, cmd))
 
 $(J.deriveJSON defaultJSON ''MsgFlags)
 

src/Simplex/Messaging/Server/CLI.hs

@@ -24,6 +24,7 @@ import qualified Data.X509.File as XF
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
+import Simplex.Messaging.Client (SocksMode (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
@@ -301,3 +302,9 @@ clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>=
 
 getEnvPath :: String -> FilePath -> IO FilePath
 getEnvPath name def = maybe def (\case "" -> def; f -> f) <$> lookupEnv name
+
+textToSocksMode :: Text -> SocksMode
+textToSocksMode = \case
+  "always" -> SMAlways
+  "onion" -> SMOnion
+  s -> error . T.unpack $ "Invalid socks_mode: " <> s

src/Simplex/Messaging/Server/Control.hs

@@ -4,8 +4,9 @@
 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, SenderId)
+import Simplex.Messaging.Protocol (BasicAuth)
 
 data CPClientRole = CPRNone | CPRUser | CPRAdmin
   deriving (Eq)
@@ -21,7 +22,7 @@ data ControlProtocol
   | CPSockets
   | CPSocketThreads
   | CPServerInfo
-  | CPDelete SenderId
+  | CPDelete ByteString
   | CPSave
   | CPHelp
   | CPQuit

src/Simplex/Messaging/Server/DataLog.hs

@@ -1,62 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Server.DataLog where
-
-import Control.Applicative ((<|>))
-import Control.Monad (foldM)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Simplex.Messaging.Protocol (BlobId)
-import Simplex.Messaging.Server.DataStore
-import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Transport.Buffer (trimCR)
-import Simplex.Messaging.Util (ifM)
-import System.Directory (doesFileExist)
-import System.IO
-
-data DataLogRecord = CreateBlob DataRec | DeleteBlob BlobId
-
-instance StrEncoding DataLogRecord where
-  strEncode = \case
-    CreateBlob d -> strEncode (Str "CREATE", d)
-    DeleteBlob dId -> strEncode (Str "DELETE", dId)
-  strP =
-    "CREATE " *> (CreateBlob <$> strP)
-      <|> "DELETE " *> (DeleteBlob <$> strP)
-
-logCreateBlob :: StoreLog 'WriteMode -> DataRec -> IO ()
-logCreateBlob s = writeStoreLogRecord s . CreateBlob
-
-logDeleteBlob :: StoreLog 'WriteMode -> BlobId -> IO ()
-logDeleteBlob s = writeStoreLogRecord s . DeleteBlob
-
-readWriteDataLog :: FilePath -> IO (Map BlobId DataRec, StoreLog 'WriteMode)
-readWriteDataLog f = do
-  ds <- ifM (doesFileExist f) (readDataBlobs f) (pure M.empty)
-  s <- openWriteStoreLog f
-  writeDataBlobs s ds
-  pure (ds, s)
-
-writeDataBlobs :: StoreLog 'WriteMode -> Map BlobId DataRec -> IO ()
-writeDataBlobs = mapM_ . logCreateBlob
-
-readDataBlobs :: FilePath -> IO (Map BlobId DataRec)
-readDataBlobs f = foldM processLine M.empty . LB.lines =<< LB.readFile f
-  where
-    processLine :: Map BlobId DataRec -> LB.ByteString -> IO (Map BlobId DataRec)
-    processLine m s' = case strDecode $ trimCR s of
-      Right r -> pure $ procLogRecord r
-      Left e -> m <$ printError e
-      where
-        s = LB.toStrict s'
-        procLogRecord :: DataLogRecord -> Map BlobId DataRec
-        procLogRecord = \case
-          CreateBlob d -> M.insert (dataId d) d m
-          DeleteBlob dId -> M.delete dId m
-        printError :: String -> IO ()
-        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s

src/Simplex/Messaging/Server/DataStore.hs

@@ -1,19 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simplex.Messaging.Server.DataStore where
-
-import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol
-
-data DataRec = DataRec
-  { dataId :: BlobId,
-    dataKey :: DataPublicAuthKey,
-    dataBlob :: DataBlob
-  }
-
-instance StrEncoding DataRec where
-  strEncode DataRec {dataId, dataKey, dataBlob} = strEncode (Str "v1", dataId, dataKey, dataBlob)
-  strP = do
-    (dataId, dataKey, dataBlob) <- "v1 " *> strP
-    pure DataRec {dataId, dataKey, dataBlob}

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

@@ -1,15 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
 import Control.Concurrent (ThreadId)
-import Control.Logger.Simple
-import Control.Monad
+import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
@@ -19,7 +17,6 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (isJust, isNothing)
-import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Clock.System (SystemTime)
 import Data.X509.Validation (Fingerprint (..))
@@ -31,8 +28,6 @@ import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, new
 import Simplex.Messaging.Crypto (KeyHash (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.DataLog
-import Simplex.Messaging.Server.DataStore
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
 import Simplex.Messaging.Server.MsgStore.STM
@@ -56,7 +51,6 @@ data ServerConfig = ServerConfig
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLogFile :: Maybe FilePath,
-    dataLogFile :: Maybe FilePath,
     storeMsgsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
@@ -79,8 +73,6 @@ 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,
@@ -112,7 +104,7 @@ defaultMessageExpiration =
 defaultInactiveClientExpiration :: ExpirationConfig
 defaultInactiveClientExpiration =
   ExpirationConfig
-    { ttl = 21600, -- seconds, 6 hours
+    { ttl = 43200, -- seconds, 12 hours
       checkInterval = 3600 -- seconds, 1 hours
     }
 
@@ -126,27 +118,21 @@ data Env = Env
     serverIdentity :: KeyHash,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
-    dataStore :: TMap BlobId DataRec,
     random :: TVar ChaChaDRG,
     storeLog :: Maybe (StoreLog 'WriteMode),
-    dataLog :: Maybe (StoreLog 'WriteMode),
     tlsServerParams :: T.ServerParams,
     serverStats :: ServerStats,
     sockets :: SocketState,
     clientSeq :: TVar ClientId,
-    clients :: TVar (IntMap (Maybe Client)),
+    clients :: TVar (IntMap Client),
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
-type Subscribed = Bool
-
 data Server = Server
-  { subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
-    subscribers :: TMap RecipientId (TVar Client),
-    ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
-    notifiers :: TMap NotifierId (TVar Client),
-    pendingENDs :: TVar (IntMap (NonEmpty RecipientId)),
-    pendingNtfENDs :: TVar (IntMap (NonEmpty NotifierId)),
+  { subscribedQ :: TQueue (RecipientId, Client),
+    subscribers :: TMap RecipientId Client,
+    ntfSubscribedQ :: TQueue (NotifierId, Client),
+    notifiers :: TMap NotifierId Client,
     savingLock :: Lock
   }
 
@@ -156,13 +142,11 @@ newtype ProxyAgent = ProxyAgent
 
 type ClientId = Int
 
-data VerificationResult = VRVerified (Maybe QueueRec) | VRVerifiedData (Maybe DataRec) | VRFailed
-
 data Client = Client
   { clientId :: ClientId,
     subscriptions :: TMap RecipientId Sub,
     ntfSubscriptions :: TMap NotifierId (),
-    rcvQ :: TBQueue (NonEmpty (VerificationResult, Transmission Cmd)),
+    rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
     sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
     procThreads :: TVar Int,
@@ -176,88 +160,68 @@ data Client = Client
     sndActiveAt :: TVar SystemTime
   }
 
-data ServerSub = ServerSub (TVar SubscriptionThread) | ProhibitSub
-
-data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId)
+data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
 
 data Sub = Sub
-  { subThread :: ServerSub, -- Nothing value indicates that sub
+  { subThread :: TVar SubscriptionThread,
     delivered :: TMVar MsgId
   }
 
-newServer :: IO Server
+newServer :: STM Server
 newServer = do
-  subscribedQ <- newTQueueIO
-  subscribers <- TM.emptyIO
-  ntfSubscribedQ <- newTQueueIO
-  notifiers <- TM.emptyIO
-  pendingENDs <- newTVarIO IM.empty
-  pendingNtfENDs <- newTVarIO IM.empty
-  savingLock <- atomically createLock
-  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, pendingENDs, pendingNtfENDs, savingLock}
+  subscribedQ <- newTQueue
+  subscribers <- TM.empty
+  ntfSubscribedQ <- newTQueue
+  notifiers <- TM.empty
+  savingLock <- createLock
+  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
 
-newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
-newClient clientId qSize thVersion sessionId createdAt = do
-  subscriptions <- TM.emptyIO
-  ntfSubscriptions <- TM.emptyIO
-  rcvQ <- newTBQueueIO qSize
-  sndQ <- newTBQueueIO qSize
-  msgQ <- newTBQueueIO qSize
-  procThreads <- newTVarIO 0
-  endThreads <- newTVarIO IM.empty
-  endThreadSeq <- newTVarIO 0
-  connected <- newTVarIO True
-  rcvActiveAt <- newTVarIO createdAt
-  sndActiveAt <- newTVarIO createdAt
+newClient :: TVar ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> STM Client
+newClient nextClientId qSize thVersion sessionId createdAt = do
+  clientId <- stateTVar nextClientId $ \next -> (next, next + 1)
+  subscriptions <- TM.empty
+  ntfSubscriptions <- TM.empty
+  rcvQ <- newTBQueue qSize
+  sndQ <- newTBQueue qSize
+  msgQ <- newTBQueue qSize
+  procThreads <- newTVar 0
+  endThreads <- newTVar IM.empty
+  endThreadSeq <- newTVar 0
+  connected <- newTVar True
+  rcvActiveAt <- newTVar createdAt
+  sndActiveAt <- newTVar createdAt
   return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription st = do
   delivered <- newEmptyTMVar
-  subThread <- ServerSub <$> newTVar st
+  subThread <- newTVar st
   return Sub {subThread, delivered}
 
-newProhibitedSub :: STM Sub
-newProhibitedSub = do
-  delivered <- newEmptyTMVar
-  return Sub {subThread = ProhibitSub, delivered}
-
 newEnv :: ServerConfig -> IO Env
-newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, dataLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
-  server <- newServer
-  queueStore <- newQueueStore
-  msgStore <- newMsgStore
-  dataStore <- TM.emptyIO
-  random <- C.newRandom
-  storeLog <-
-    forM storeLogFile $ \f -> do
-      logInfo $ "restoring queues from file " <> T.pack f
-      restoreQueues queueStore f
-  dataLog <-
-    forM dataLogFile $ \f -> do
-      logInfo $ "restoring data blobs from file " <> T.pack f
-      restoreDataBlobs dataStore f
+newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
+  server <- atomically newServer
+  queueStore <- atomically newQueueStore
+  msgStore <- atomically newMsgStore
+  random <- liftIO C.newRandom
+  storeLog <- restoreQueues queueStore `mapM` storeLogFile
   tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
   Fingerprint fp <- loadFingerprint caCertificateFile
   let serverIdentity = KeyHash fp
-  serverStats <- newServerStats =<< getCurrentTime
-  sockets <- newSocketState
+  serverStats <- atomically . newServerStats =<< getCurrentTime
+  sockets <- atomically newSocketState
   clientSeq <- newTVarIO 0
   clients <- newTVarIO mempty
-  proxyAgent <- newSMPProxyAgent smpAgentCfg random
-  pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, dataStore, random, storeLog, dataLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
+  proxyAgent <- atomically $ newSMPProxyAgent smpAgentCfg random
+  pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
   where
     restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
     restoreQueues QueueStore {queues, senders, notifiers} f = do
       (qs, s) <- readWriteStoreLog f
-      atomically . writeTVar queues =<< mapM newTVarIO qs
-      atomically $ writeTVar senders $! M.foldr' addSender M.empty qs
-      atomically $ writeTVar notifiers $! M.foldr' addNotifier M.empty qs
-      pure s
-    restoreDataBlobs :: TMap BlobId DataRec -> FilePath -> IO (StoreLog 'WriteMode)
-    restoreDataBlobs dataStore f = do
-      (ds, s) <- readWriteDataLog f
-      atomically $ writeTVar dataStore ds
+      atomically $ do
+        writeTVar queues =<< mapM newTVar qs
+        writeTVar senders $! M.foldr' addSender M.empty qs
+        writeTVar notifiers $! M.foldr' addNotifier M.empty qs
       pure s
     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
     addSender q = M.insert (senderId q) (recipientId q)
@@ -283,7 +247,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
           | isJust (storeMsgsFile config) = SPMMessages
           | otherwise = SPMQueues
 
-newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
+newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM ProxyAgent
 newSMPProxyAgent smpAgentCfg random = do
   smpAgent <- newSMPClientAgent smpAgentCfg random
   pure ProxyAgent {smpAgent}

src/Simplex/Messaging/Server/Main.hs

@@ -79,7 +79,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
     defaultServerPort = "5223"
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
-    dataLogFilePath = combine logPath "smp-server-data.log"
     httpsCertFile = combine cfgPath "web.cert"
     httpsKeyFile = combine cfgPath "web.key"
     defaultStaticPath = combine logPath "www"
@@ -263,7 +262,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
               privateKeyFile = c serverKeyFile,
               certificateFile = c serverCrtFile,
               storeLogFile = enableStoreLog $> storeLogFilePath,
-              dataLogFile = enableStoreLog $> dataLogFilePath,
               storeMsgsFile =
                 let messagesPath = combine logPath "smp-server-messages.log"
                  in case iniOnOff "STORE_LOG" "restore_messages" ini of
@@ -291,7 +289,6 @@ 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
@@ -308,7 +305,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
                           networkConfig =
                             defaultNetworkConfig
                               { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
-                                socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
+                                socksMode = either (const SMOnion) textToSocksMode $ lookupValue "PROXY" "socks_mode" ini,
                                 hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini,
                                 requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
                               }

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

@@ -9,21 +9,23 @@
 
 module Simplex.Messaging.Server.MsgStore.STM
   ( STMMsgStore,
-    MsgQueue (msgQueue),
+    MsgQueue (..),
     newMsgStore,
     getMsgQueue,
     delMsgQueue,
     delMsgQueueSize,
+    flushMsgQueue,
+    snapshotMsgQueue,
     writeMsg,
     tryPeekMsg,
-    tryPeekMsgIO,
+    peekMsg,
     tryDelMsg,
     tryDelPeekMsg,
     deleteExpiredMsgs,
-    getQueueSize,
   )
 where
 
+import Control.Concurrent.STM.TQueue (flushTQueue)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -42,17 +44,12 @@ data MsgQueue = MsgQueue
 
 type STMMsgStore = TMap RecipientId MsgQueue
 
-newMsgStore :: IO STMMsgStore
-newMsgStore = TM.emptyIO
+newMsgStore :: STM STMMsgStore
+newMsgStore = TM.empty
 
--- 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
+getMsgQueue :: STMMsgStore -> RecipientId -> Int -> STM MsgQueue
+getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
   where
-    maybeNewQ = TM.lookup rId st >>= maybe newQ pure
     newQ = do
       msgQueue <- newTQueue
       canWrite <- newTVar True
@@ -61,14 +58,25 @@ getMsgQueue st rId quota = TM.lookupIO rId st >>= maybe (atomically maybeNewQ) p
       TM.insert rId q st
       pure q
 
-delMsgQueue :: STMMsgStore -> RecipientId -> IO ()
-delMsgQueue st rId = atomically $ TM.delete rId st
+delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
+delMsgQueue st rId = TM.delete rId st
 
-delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int
-delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size)
+delMsgQueueSize :: STMMsgStore -> RecipientId -> STM Int
+delMsgQueueSize st rId = TM.lookupDelete rId st >>= maybe (pure 0) (\MsgQueue {size} -> readTVar size)
 
-writeMsg :: MsgQueue -> Message -> IO (Maybe (Message, Bool))
-writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do
+flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
+
+snapshotMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
+snapshotMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . msgQueue)
+  where
+    snapshotTQueue q = do
+      msgs <- flushTQueue q
+      mapM_ (writeTQueue q) msgs
+      pure msgs
+
+writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool))
+writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do
   canWrt <- readTVar canWrite
   empty <- isEmptyTQueue q
   if canWrt || empty
@@ -83,47 +91,43 @@ writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do
   where
     msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
 
-tryPeekMsgIO :: MsgQueue -> IO (Maybe Message)
-tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue
-{-# INLINE tryPeekMsgIO #-}
-
--- TODO remove once deliverToSub is split
 tryPeekMsg :: MsgQueue -> STM (Maybe Message)
 tryPeekMsg = tryPeekTQueue . msgQueue
 {-# INLINE tryPeekMsg #-}
 
-tryDelMsg :: MsgQueue -> MsgId -> IO (Maybe Message)
-tryDelMsg mq msgId' = atomically $
+peekMsg :: MsgQueue -> STM Message
+peekMsg = peekTQueue . msgQueue
+{-# INLINE peekMsg #-}
+
+tryDelMsg :: MsgQueue -> MsgId -> STM (Maybe Message)
+tryDelMsg mq msgId' =
   tryPeekMsg mq >>= \case
     msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg_ mq >> pure msg_
+      | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_
       | otherwise -> pure Nothing
     _ -> pure Nothing
 
 -- atomic delete (== read) last and peek next message if available
-tryDelPeekMsg :: MsgQueue -> MsgId -> IO (Maybe Message, Maybe Message)
-tryDelPeekMsg mq msgId' = atomically $
+tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message)
+tryDelPeekMsg mq msgId' =
   tryPeekMsg mq >>= \case
     msg_@(Just msg)
-      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg mq)
+      | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
       | otherwise -> pure (Nothing, msg_)
     _ -> pure (Nothing, Nothing)
 
-deleteExpiredMsgs :: MsgQueue -> Int64 -> IO Int
-deleteExpiredMsgs mq old = atomically $ loop 0
+deleteExpiredMsgs :: MsgQueue -> Int64 -> STM Int
+deleteExpiredMsgs mq old = loop 0
   where
     loop dc =
       tryPeekMsg mq >>= \case
         Just Message {msgTs}
           | systemSeconds msgTs < old ->
-              tryDeleteMsg_ mq >> loop (dc + 1)
+              tryDeleteMsg mq >> loop (dc + 1)
         _ -> pure dc
 
-tryDeleteMsg_ :: MsgQueue -> STM ()
-tryDeleteMsg_ MsgQueue {msgQueue = q, size} =
+tryDeleteMsg :: MsgQueue -> STM ()
+tryDeleteMsg MsgQueue {msgQueue = q, size} =
   tryReadTQueue q >>= \case
     Just _ -> modifyTVar' size (subtract 1)
     _ -> pure ()
-
-getQueueSize :: MsgQueue -> IO Int
-getQueueSize MsgQueue {size} = readTVarIO size

src/Simplex/Messaging/Server/QueueStore.hs

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

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

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

src/Simplex/Messaging/Server/Stats.hs

@@ -4,78 +4,52 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Messaging.Server.Stats where
 
 import Control.Applicative (optional, (<|>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Hashable (hash)
-import Data.IORef
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IS
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Time.Calendar.Month (pattern MonthDay)
 import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
 import Data.Time.Clock (UTCTime (..))
-import GHC.IORef (atomicSwapIORef)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (EntityId (..))
-import Simplex.Messaging.Util (atomicModifyIORef'_, unlessM)
+import Simplex.Messaging.Protocol (RecipientId)
+import UnliftIO.STM
 
 data ServerStats = ServerStats
-  { fromTime :: IORef UTCTime,
-    qCreated :: IORef Int,
-    qSecured :: IORef Int,
-    qDeletedAll :: IORef Int,
-    qDeletedAllB :: IORef Int,
-    qDeletedNew :: IORef Int,
-    qDeletedSecured :: IORef Int,
-    qSub :: IORef Int, -- only includes subscriptions when there were pending messages
-    -- qSubNoMsg :: IORef Int, -- this stat creates too many STM transactions
-    qSubAllB :: IORef Int, -- count of all subscription batches (with and without pending messages)
-    qSubAuth :: IORef Int,
-    qSubDuplicate :: IORef Int,
-    qSubProhibited :: IORef Int,
-    qSubEnd :: IORef Int,
-    qSubEndB :: IORef Int,
-    ntfCreated :: IORef Int,
-    ntfDeleted :: IORef Int,
-    ntfDeletedB :: IORef Int,
-    ntfSub :: IORef Int,
-    ntfSubB :: IORef Int,
-    ntfSubAuth :: IORef Int,
-    ntfSubDuplicate :: IORef Int,
-    msgSent :: IORef Int,
-    msgSentAuth :: IORef Int,
-    msgSentQuota :: IORef Int,
-    msgSentLarge :: IORef Int,
-    msgRecv :: IORef Int,
-    msgRecvGet :: IORef Int,
-    msgGet :: IORef Int,
-    msgGetNoMsg :: IORef Int,
-    msgGetAuth :: IORef Int,
-    msgGetDuplicate :: IORef Int,
-    msgGetProhibited :: IORef Int,
-    msgExpired :: IORef Int,
-    activeQueues :: PeriodStats,
-    -- subscribedQueues :: PeriodStats, -- this stat uses too much memory
-    msgSentNtf :: IORef Int, -- sent messages with NTF flag
-    msgRecvNtf :: IORef Int, -- received messages with NTF flag
-    activeQueuesNtf :: PeriodStats,
-    msgNtfs :: IORef Int, -- messages notications delivered to NTF server (<= msgSentNtf)
-    msgNtfNoSub :: IORef Int, -- no subscriber to notifications (e.g., NTF server not connected)
-    msgNtfLost :: IORef Int, -- notification is lost because NTF delivery queue is full
+  { fromTime :: TVar UTCTime,
+    qCreated :: TVar Int,
+    qSecured :: TVar Int,
+    qDeletedAll :: TVar Int,
+    qDeletedNew :: TVar Int,
+    qDeletedSecured :: TVar Int,
+    qSub :: TVar Int,
+    qSubAuth :: TVar Int,
+    qSubDuplicate :: TVar Int,
+    qSubProhibited :: TVar Int,
+    msgSent :: TVar Int,
+    msgSentAuth :: TVar Int,
+    msgSentQuota :: TVar Int,
+    msgSentLarge :: TVar Int,
+    msgRecv :: TVar Int,
+    msgExpired :: TVar Int,
+    activeQueues :: PeriodStats RecipientId,
+    msgSentNtf :: TVar Int, -- sent messages with NTF flag
+    msgRecvNtf :: TVar Int, -- received messages with NTF flag
+    activeQueuesNtf :: PeriodStats RecipientId,
+    msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf)
+    msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected)
+    msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full
     pRelays :: ProxyStats,
     pRelaysOwn :: ProxyStats,
     pMsgFwds :: ProxyStats,
     pMsgFwdsOwn :: ProxyStats,
-    pMsgFwdsRecv :: IORef Int,
-    qCount :: IORef Int,
-    msgCount :: IORef Int
+    pMsgFwdsRecv :: TVar Int,
+    qCount :: TVar Int,
+    msgCount :: TVar Int
   }
 
 data ServerStatsData = ServerStatsData
@@ -83,39 +57,22 @@ data ServerStatsData = ServerStatsData
     _qCreated :: Int,
     _qSecured :: Int,
     _qDeletedAll :: Int,
-    _qDeletedAllB :: Int,
     _qDeletedNew :: Int,
     _qDeletedSecured :: Int,
     _qSub :: 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,
     _msgSentAuth :: Int,
     _msgSentQuota :: Int,
     _msgSentLarge :: Int,
     _msgRecv :: Int,
-    _msgRecvGet :: Int,
-    _msgGet :: Int,
-    _msgGetNoMsg :: Int,
-    _msgGetAuth :: Int,
-    _msgGetDuplicate :: Int,
-    _msgGetProhibited :: Int,
     _msgExpired :: Int,
-    _activeQueues :: PeriodStatsData,
+    _activeQueues :: PeriodStatsData RecipientId,
     _msgSentNtf :: Int,
     _msgRecvNtf :: Int,
-    _activeQueuesNtf :: PeriodStatsData,
+    _activeQueuesNtf :: PeriodStatsData RecipientId,
     _msgNtfs :: Int,
     _msgNtfNoSub :: Int,
     _msgNtfLost :: Int,
@@ -129,89 +86,55 @@ data ServerStatsData = ServerStatsData
   }
   deriving (Show)
 
-newServerStats :: UTCTime -> IO ServerStats
+newServerStats :: UTCTime -> STM ServerStats
 newServerStats ts = do
-  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
+  fromTime <- newTVar ts
+  qCreated <- newTVar 0
+  qSecured <- newTVar 0
+  qDeletedAll <- newTVar 0
+  qDeletedNew <- newTVar 0
+  qDeletedSecured <- newTVar 0
+  qSub <- newTVar 0
+  qSubAuth <- newTVar 0
+  qSubDuplicate <- newTVar 0
+  qSubProhibited <- newTVar 0
+  msgSent <- newTVar 0
+  msgSentAuth <- newTVar 0
+  msgSentQuota <- newTVar 0
+  msgSentLarge <- newTVar 0
+  msgRecv <- newTVar 0
+  msgExpired <- newTVar 0
   activeQueues <- newPeriodStats
-  msgSentNtf <- newIORef 0
-  msgRecvNtf <- newIORef 0
+  msgSentNtf <- newTVar 0
+  msgRecvNtf <- newTVar 0
   activeQueuesNtf <- newPeriodStats
-  msgNtfs <- newIORef 0
-  msgNtfNoSub <- newIORef 0
-  msgNtfLost <- newIORef 0
+  msgNtfs <- newTVar 0
+  msgNtfNoSub <- newTVar 0
+  msgNtfLost <- newTVar 0
   pRelays <- newProxyStats
   pRelaysOwn <- newProxyStats
   pMsgFwds <- newProxyStats
   pMsgFwdsOwn <- newProxyStats
-  pMsgFwdsRecv <- newIORef 0
-  qCount <- newIORef 0
-  msgCount <- newIORef 0
+  pMsgFwdsRecv <- newTVar 0
+  qCount <- newTVar 0
+  msgCount <- newTVar 0
   pure
     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,
@@ -229,89 +152,55 @@ newServerStats ts = do
         msgCount
       }
 
-getServerStatsData :: ServerStats -> IO ServerStatsData
+getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
-  _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
+  _fromTime <- readTVar $ fromTime s
+  _qCreated <- readTVar $ qCreated s
+  _qSecured <- readTVar $ qSecured s
+  _qDeletedAll <- readTVar $ qDeletedAll s
+  _qDeletedNew <- readTVar $ qDeletedNew s
+  _qDeletedSecured <- readTVar $ qDeletedSecured s
+  _qSub <- readTVar $ qSub s
+  _qSubAuth <- readTVar $ qSubAuth s
+  _qSubDuplicate <- readTVar $ qSubDuplicate s
+  _qSubProhibited <- readTVar $ qSubProhibited s
+  _msgSent <- readTVar $ msgSent s
+  _msgSentAuth <- readTVar $ msgSentAuth s
+  _msgSentQuota <- readTVar $ msgSentQuota s
+  _msgSentLarge <- readTVar $ msgSentLarge s
+  _msgRecv <- readTVar $ msgRecv s
+  _msgExpired <- readTVar $ msgExpired s
   _activeQueues <- getPeriodStatsData $ activeQueues s
-  _msgSentNtf <- readIORef $ msgSentNtf s
-  _msgRecvNtf <- readIORef $ msgRecvNtf s
+  _msgSentNtf <- readTVar $ msgSentNtf s
+  _msgRecvNtf <- readTVar $ msgRecvNtf s
   _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
-  _msgNtfs <- readIORef $ msgNtfs s
-  _msgNtfNoSub <- readIORef $ msgNtfNoSub s
-  _msgNtfLost <- readIORef $ msgNtfLost s
+  _msgNtfs <- readTVar $ msgNtfs s
+  _msgNtfNoSub <- readTVar $ msgNtfNoSub s
+  _msgNtfLost <- readTVar $ msgNtfLost s
   _pRelays <- getProxyStatsData $ pRelays s
   _pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
   _pMsgFwds <- getProxyStatsData $ pMsgFwds s
   _pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s
-  _pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s
-  _qCount <- readIORef $ qCount s
-  _msgCount <- readIORef $ msgCount s
+  _pMsgFwdsRecv <- readTVar $ pMsgFwdsRecv s
+  _qCount <- readTVar $ qCount s
+  _msgCount <- readTVar $ msgCount s
   pure
     ServerStatsData
       { _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,
@@ -329,56 +218,38 @@ getServerStatsData s = do
         _msgCount
       }
 
--- this function is not thread safe, it is used on server start only
-setServerStats :: ServerStats -> ServerStatsData -> IO ()
+setServerStats :: ServerStats -> ServerStatsData -> STM ()
 setServerStats s d = do
-  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
+  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 (qSubAuth s) $! _qSubAuth d
+  writeTVar (qSubDuplicate s) $! _qSubDuplicate d
+  writeTVar (qSubProhibited s) $! _qSubProhibited 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 (msgExpired s) $! _msgExpired d
   setPeriodStats (activeQueues s) (_activeQueues d)
-  writeIORef (msgSentNtf s) $! _msgSentNtf d
-  writeIORef (msgRecvNtf s) $! _msgRecvNtf d
+  writeTVar (msgSentNtf s) $! _msgSentNtf d
+  writeTVar (msgRecvNtf s) $! _msgRecvNtf d
   setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
-  writeIORef (msgNtfs s) $! _msgNtfs d
-  writeIORef (msgNtfNoSub s) $! _msgNtfNoSub d
-  writeIORef (msgNtfLost s) $! _msgNtfLost d
+  writeTVar (msgNtfs s) $! _msgNtfs d
+  writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d
+  writeTVar (msgNtfLost s) $! _msgNtfLost d
   setProxyStats (pRelays s) $! _pRelays d
   setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
   setProxyStats (pMsgFwds s) $! _pMsgFwds d
   setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d
-  writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
-  writeIORef (qCount s) $! _qCount d
-  writeIORef (msgCount s) $! _msgCount d
+  writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
+  writeTVar (qCount s) $! _qCount d
+  writeTVar (msgCount s) $! _msgCount d
 
 instance StrEncoding ServerStatsData where
   strEncode d =
@@ -389,33 +260,16 @@ 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),
-        "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),
         "msgSentAuth=" <> strEncode (_msgSentAuth d),
         "msgSentQuota=" <> strEncode (_msgSentQuota d),
         "msgSentLarge=" <> strEncode (_msgSentLarge d),
         "msgRecv=" <> strEncode (_msgRecv d),
-        "msgRecvGet=" <> strEncode (_msgRecvGet d),
-        "msgGet=" <> strEncode (_msgGet d),
-        "msgGetNoMsg=" <> strEncode (_msgGetNoMsg d),
-        "msgGetAuth=" <> strEncode (_msgGetAuth d),
-        "msgGetDuplicate=" <> strEncode (_msgGetDuplicate d),
-        "msgGetProhibited=" <> strEncode (_msgGetProhibited d),
         "msgExpired=" <> strEncode (_msgExpired d),
         "msgSentNtf=" <> strEncode (_msgSentNtf d),
         "msgRecvNtf=" <> strEncode (_msgRecvNtf d),
@@ -443,34 +297,16 @@ 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 <- 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
     _msgSentAuth <- opt "msgSentAuth="
     _msgSentQuota <- opt "msgSentQuota="
     _msgSentLarge <- opt "msgSentLarge="
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
-    _msgRecvGet <- opt "msgRecvGet="
-    _msgGet <- opt "msgGet="
-    _msgGetNoMsg <- opt "msgGetNoMsg="
-    _msgGetAuth <- opt "msgGetAuth="
-    _msgGetDuplicate <- opt "msgGetDuplicate="
-    _msgGetProhibited <- opt "msgGetProhibited="
     _msgExpired <- opt "msgExpired="
     _msgSentNtf <- opt "msgSentNtf="
     _msgRecvNtf <- opt "msgRecvNtf="
@@ -485,10 +321,6 @@ instance StrEncoding ServerStatsData where
           _week <- "weekMsgQueues=" *> strP <* A.endOfLine
           _month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
           pure PeriodStatsData {_day, _week, _month}
-    _subscribedQueues <-
-      optional ("subscribedQueues:" <* A.endOfLine) >>= \case
-        Just _ -> newPeriodStatsData <$ (strP @PeriodStatsData <* optional A.endOfLine)
-        _ -> pure newPeriodStatsData
     _activeQueuesNtf <-
       optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
         Just _ -> strP <* optional A.endOfLine
@@ -504,34 +336,17 @@ instance StrEncoding ServerStatsData where
           _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,
           _msgSentNtf,
           _msgRecvNtf,
@@ -550,59 +365,55 @@ 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 = PeriodStats
-  { day :: IORef IntSet,
-    week :: IORef IntSet,
-    month :: IORef IntSet
+data PeriodStats a = PeriodStats
+  { day :: TVar (Set a),
+    week :: TVar (Set a),
+    month :: TVar (Set a)
   }
 
-newPeriodStats :: IO PeriodStats
+newPeriodStats :: STM (PeriodStats a)
 newPeriodStats = do
-  day <- newIORef IS.empty
-  week <- newIORef IS.empty
-  month <- newIORef IS.empty
+  day <- newTVar S.empty
+  week <- newTVar S.empty
+  month <- newTVar S.empty
   pure PeriodStats {day, week, month}
 
-data PeriodStatsData = PeriodStatsData
-  { _day :: IntSet,
-    _week :: IntSet,
-    _month :: IntSet
+data PeriodStatsData a = PeriodStatsData
+  { _day :: Set a,
+    _week :: Set a,
+    _month :: Set a
   }
   deriving (Show)
 
-newPeriodStatsData :: PeriodStatsData
-newPeriodStatsData = PeriodStatsData {_day = IS.empty, _week = IS.empty, _month = IS.empty}
+newPeriodStatsData :: PeriodStatsData a
+newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty}
 
-getPeriodStatsData :: PeriodStats -> IO PeriodStatsData
+getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
 getPeriodStatsData s = do
-  _day <- readIORef $ day s
-  _week <- readIORef $ week s
-  _month <- readIORef $ month s
+  _day <- readTVar $ day s
+  _week <- readTVar $ week s
+  _month <- readTVar $ month s
   pure PeriodStatsData {_day, _week, _month}
 
--- this function is not thread safe, it is used on server start only
-setPeriodStats :: PeriodStats -> PeriodStatsData -> IO ()
+setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
 setPeriodStats s d = do
-  writeIORef (day s) $! _day d
-  writeIORef (week s) $! _week d
-  writeIORef (month s) $! _month d
+  writeTVar (day s) $! _day d
+  writeTVar (week s) $! _week d
+  writeTVar (month s) $! _month d
 
-instance StrEncoding PeriodStatsData where
+instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
   strEncode PeriodStatsData {_day, _week, _month} =
-    "dayHashes=" <> strEncode _day <> "\nweekHashes=" <> strEncode _week <> "\nmonthHashes=" <> strEncode _month
+    "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
   strP = do
-    _day <- ("day=" *> bsSetP <|> "dayHashes=" *> strP) <* A.endOfLine
-    _week <- ("week=" *> bsSetP <|> "weekHashes=" *> strP) <* A.endOfLine
-    _month <- "month=" *> bsSetP <|> "monthHashes=" *> strP
+    _day <- "day=" *> strP <* A.endOfLine
+    _week <- "week=" *> strP <* A.endOfLine
+    _month <- "month=" *> strP
     pure PeriodStatsData {_day, _week, _month}
-    where
-      bsSetP = S.foldl' (\s -> (`IS.insert` s) . hash) IS.empty <$> strP @(Set ByteString)
 
 data PeriodStatCounts = PeriodStatCounts
   { dayCount :: String,
@@ -610,7 +421,7 @@ data PeriodStatCounts = PeriodStatCounts
     monthCount :: String
   }
 
-periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts
+periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
 periodStatCounts ps ts = do
   let d = utctDay ts
       (_, wDay) = mondayStartWeek d
@@ -620,34 +431,33 @@ periodStatCounts ps ts = do
   monthCount <- periodCount mDay $ month ps
   pure PeriodStatCounts {dayCount, weekCount, monthCount}
   where
-    periodCount :: Int -> IORef IntSet -> IO String
-    periodCount 1 ref = show . IS.size <$> atomicSwapIORef ref IS.empty
+    periodCount :: Int -> TVar (Set a) -> STM String
+    periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
     periodCount _ _ = pure ""
 
-updatePeriodStats :: PeriodStats -> EntityId -> IO ()
-updatePeriodStats ps (EntityId pId) = do
-  updatePeriod $ day ps
-  updatePeriod $ week ps
-  updatePeriod $ month ps
+updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
+updatePeriodStats stats pId = do
+  updatePeriod day
+  updatePeriod week
+  updatePeriod month
   where
-    ph = hash pId
-    updatePeriod ref = unlessM (IS.member ph <$> readIORef ref) $ atomicModifyIORef'_ ref $ IS.insert ph
+    updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)
 
 data ProxyStats = ProxyStats
-  { 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
+  { 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
   }
 
-newProxyStats :: IO ProxyStats
+newProxyStats :: STM ProxyStats
 newProxyStats = do
-  pRequests <- newIORef 0
-  pSuccesses <- newIORef 0
-  pErrorsConnect <- newIORef 0
-  pErrorsCompat <- newIORef 0
-  pErrorsOther <- newIORef 0
+  pRequests <- newTVar 0
+  pSuccesses <- newTVar 0
+  pErrorsConnect <- newTVar 0
+  pErrorsCompat <- newTVar 0
+  pErrorsOther <- newTVar 0
   pure ProxyStats {pRequests, pSuccesses, pErrorsConnect, pErrorsCompat, pErrorsOther}
 
 data ProxyStatsData = ProxyStatsData
@@ -662,32 +472,31 @@ data ProxyStatsData = ProxyStatsData
 newProxyStatsData :: ProxyStatsData
 newProxyStatsData = ProxyStatsData {_pRequests = 0, _pSuccesses = 0, _pErrorsConnect = 0, _pErrorsCompat = 0, _pErrorsOther = 0}
 
-getProxyStatsData :: ProxyStats -> IO ProxyStatsData
+getProxyStatsData :: ProxyStats -> STM ProxyStatsData
 getProxyStatsData s = do
-  _pRequests <- readIORef $ pRequests s
-  _pSuccesses <- readIORef $ pSuccesses s
-  _pErrorsConnect <- readIORef $ pErrorsConnect s
-  _pErrorsCompat <- readIORef $ pErrorsCompat s
-  _pErrorsOther <- readIORef $ pErrorsOther s
+  _pRequests <- readTVar $ pRequests s
+  _pSuccesses <- readTVar $ pSuccesses s
+  _pErrorsConnect <- readTVar $ pErrorsConnect s
+  _pErrorsCompat <- readTVar $ pErrorsCompat s
+  _pErrorsOther <- readTVar $ pErrorsOther s
   pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
 
-getResetProxyStatsData :: ProxyStats -> IO ProxyStatsData
+getResetProxyStatsData :: ProxyStats -> STM ProxyStatsData
 getResetProxyStatsData s = do
-  _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
+  _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
   pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
 
--- this function is not thread safe, it is used on server start only
-setProxyStats :: ProxyStats -> ProxyStatsData -> IO ()
+setProxyStats :: ProxyStats -> ProxyStatsData -> STM ()
 setProxyStats s d = do
-  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
+  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
 
 instance StrEncoding ProxyStatsData where
   strEncode ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} =

src/Simplex/Messaging/Server/StoreLog.hs

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

src/Simplex/Messaging/Session.hs

@@ -5,6 +5,9 @@
 module Simplex.Messaging.Session where
 
 import Control.Concurrent.STM
+import Control.Monad
+import Data.Composition ((.:.))
+import Data.Functor (($>))
 import Data.Time (UTCTime)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -28,10 +31,14 @@ getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pur
       pure v
 
 removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
-removeSessVar v sessKey vs =
+removeSessVar = void .:. removeSessVar'
+{-# INLINE removeSessVar #-}
+
+removeSessVar' :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM Bool
+removeSessVar' v sessKey vs =
   TM.lookup sessKey vs >>= \case
-    Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs
-    _ -> pure ()
+    Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs $> True
+    _ -> pure False
 
 tryReadSessVar :: Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a)
 tryReadSessVar sessKey vs = TM.lookup sessKey vs $>>= (tryReadTMVar . sessionVar)

src/Simplex/Messaging/TMap.hs

@@ -1,13 +1,11 @@
 module Simplex.Messaging.TMap
   ( TMap,
-    emptyIO,
+    empty,
     singleton,
     clear,
     Simplex.Messaging.TMap.null,
     Simplex.Messaging.TMap.lookup,
-    lookupIO,
     member,
-    memberIO,
     insert,
     delete,
     lookupInsert,
@@ -26,9 +24,9 @@ import qualified Data.Map.Strict as M
 
 type TMap k a = TVar (Map k a)
 
-emptyIO :: IO (TMap k a)
-emptyIO = newTVarIO M.empty
-{-# INLINE emptyIO #-}
+empty :: STM (TMap k a)
+empty = newTVar M.empty
+{-# INLINE empty #-}
 
 singleton :: k -> a -> STM (TMap k a)
 singleton k v = newTVar $ M.singleton k v
@@ -46,18 +44,10 @@ lookup :: Ord k => k -> TMap k a -> STM (Maybe a)
 lookup k m = M.lookup k <$> readTVar m
 {-# INLINE lookup #-}
 
-lookupIO :: Ord k => k -> TMap k a -> IO (Maybe a)
-lookupIO k m = M.lookup k <$> readTVarIO m
-{-# INLINE lookupIO #-}
-
 member :: Ord k => k -> TMap k a -> STM Bool
 member k m = M.member k <$> readTVar m
 {-# INLINE member #-}
 
-memberIO :: Ord k => k -> TMap k a -> IO Bool
-memberIO k m = M.member k <$> readTVarIO m
-{-# INLINE memberIO #-}
-
 insert :: Ord k => k -> a -> TMap k a -> STM ()
 insert k v m = modifyTVar' m $ M.insert k v
 {-# INLINE insert #-}

src/Simplex/Messaging/Transport.hs

@@ -47,7 +47,6 @@ module Simplex.Messaging.Transport
     authCmdsSMPVersion,
     sendingProxySMPVersion,
     sndAuthKeySMPVersion,
-    dataBlobSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -114,9 +113,9 @@ import Simplex.Messaging.Transport.Buffer
 import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
-import System.IO.Error (isEOFError)
 import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
+import UnliftIO.STM
 
 -- * Transport parameters
 
@@ -131,9 +130,6 @@ smpBlockSize = 16384
 -- 5 - basic auth for SMP servers (11/12/2022)
 -- 6 - allow creating queues without subscribing (9/10/2023)
 -- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
--- 8 - forwarding proxy protecting IP addresses and sessions of command senders (5/14/2024)
--- 9 - securing message queue by sender (SKEY command) for faster connection handshake (6/30/2024)
--- 10 - storing data blobs on SMP servers for short invitation links (7/25/2024)
 
 data SMPVersion
 
@@ -164,17 +160,14 @@ sendingProxySMPVersion = VersionSMP 8
 sndAuthKeySMPVersion :: VersionSMP
 sndAuthKeySMPVersion = VersionSMP 9
 
-dataBlobSMPVersion :: VersionSMP
-dataBlobSMPVersion = VersionSMP 10
-
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 10
+currentClientSMPRelayVersion = VersionSMP 9
 
 legacyServerSMPRelayVersion :: VersionSMP
 legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 10
+currentServerSMPRelayVersion = VersionSMP 9
 
 -- Max SMP protocol version to be used in e2e encrypted
 -- connection between client and server, as defined by SMP proxy.
@@ -182,7 +175,7 @@ currentServerSMPRelayVersion = VersionSMP 10
 -- to prevent client version fingerprinting by the
 -- destination relays when clients upgrade at different times.
 proxiedSMPRelayVersion :: VersionSMP
-proxiedSMPRelayVersion = VersionSMP 10
+proxiedSMPRelayVersion = VersionSMP 9
 
 -- minimal supported protocol version is 4
 -- TODO remove code that supports sending commands without batching
@@ -292,7 +285,7 @@ getTLS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context ->
 getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
   where
     newTLS tlsUniq = do
-      tlsBuffer <- newTBuffer
+      tlsBuffer <- atomically newTBuffer
       tlsALPN <- T.getNegotiatedProtocol cxt
       pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
 
@@ -346,12 +339,11 @@ instance Transport TLS where
 
   getLn :: TLS -> IO ByteString
   getLn TLS {tlsContext, tlsBuffer} = do
-    getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
+    getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catch` handleEOF
     where
-      handleTlsEOF = \case
-        T.PostHandshake T.Error_EOF -> E.throwIO TEBadBlock
+      handleEOF = \case
+        T.Error_EOF -> E.throwIO TEBadBlock
         e -> E.throwIO e
-      handleEOF e = if isEOFError e then E.throwIO TEBadBlock else E.throwIO e
 
 -- * SMP transport
 

src/Simplex/Messaging/Transport/Buffer.hs

@@ -17,10 +17,10 @@ data TBuffer = TBuffer
     getLock :: TMVar ()
   }
 
-newTBuffer :: IO TBuffer
+newTBuffer :: STM TBuffer
 newTBuffer = do
-  buffer <- newTVarIO ""
-  getLock <- newTMVarIO ()
+  buffer <- newTVar ""
+  getLock <- newTMVar ()
   pure TBuffer {buffer, getLock}
 
 withBufferLock :: TBuffer -> IO a -> IO a

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -2,6 +2,7 @@
 
 module Simplex.Messaging.Transport.HTTP2 where
 
+import Control.Concurrent.STM
 import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -74,7 +75,7 @@ instance HTTP2BodyChunk HS.Request where
 
 getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
 getHTTP2Body r n = do
-  bodyBuffer <- newTBuffer
+  bodyBuffer <- atomically newTBuffer
   let getPart n' = getBuffered bodyBuffer n' Nothing $ getBodyChunk r
   bodyHead <- getPart n
   let bodySize = fromMaybe 0 $ getBodySize r

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

@@ -104,13 +104,13 @@ attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP
 
 getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
 getVerifiedHTTP2ClientWith config host port disconnected setup =
-  (mkHTTPS2Client >>= runClient)
+  (atomically mkHTTPS2Client >>= runClient)
     `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
   where
-    mkHTTPS2Client :: IO HClient
+    mkHTTPS2Client :: STM HClient
     mkHTTPS2Client = do
-      connected <- newTVarIO False
-      reqQ <- newTBQueueIO $ qSize config
+      connected <- newTVar False
+      reqQ <- newTBQueue $ qSize config
       pure HClient {connected, disconnected, host, port, config, reqQ}
 
     runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)

src/Simplex/Messaging/Transport/Server.hs

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

src/Simplex/Messaging/Transport/WebSockets.hs

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

src/Simplex/Messaging/Util.hs

@@ -15,7 +15,6 @@ 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
@@ -24,7 +23,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 hiding (atomicModifyIORef')
+import UnliftIO
 import qualified UnliftIO.Exception as UE
 
 raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -167,19 +166,14 @@ threadDelay' = loop
           loop $ time - maxWait
 
 diffToMicroseconds :: NominalDiffTime -> Int64
-diffToMicroseconds diff = truncate $ diff * 1000000
-{-# INLINE diffToMicroseconds #-}
+diffToMicroseconds diff = fromIntegral ((truncate $ diff * 1000000) :: Integer)
 
 diffToMilliseconds :: NominalDiffTime -> Int64
-diffToMilliseconds diff = truncate $ diff * 1000
-{-# INLINE diffToMilliseconds #-}
+diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer)
 
 labelMyThread :: MonadIO m => String -> m ()
 labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label)
 
-atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO ()
-atomicModifyIORef'_ r f = atomicModifyIORef' r (\v -> (f v, ()))
-
 encodeJSON :: ToJSON a => a -> Text
 encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
 

src/Simplex/RemoteControl/Client.hs

@@ -305,7 +305,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
 
 catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a
 catchRCError = catchAllErrors $ \e -> case fromException e of
-  Just (TLS.Terminated _ _ (TLS.Error_Protocol _ TLS.UnknownCa)) -> RCEIdentity
+  Just (TLS.Terminated _ _ (TLS.Error_Protocol (_, _, TLS.UnknownCa))) -> RCEIdentity
   _ -> RCEException $ show e
 {-# INLINE catchRCError #-}
 

src/Simplex/RemoteControl/Discovery.hs

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

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 (EntityId (..), ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC)
+import Simplex.Messaging.Protocol (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 = EntityId "\223\142z\251",
+      senderId = "\223\142z\251",
       dhPublicKey = testDhKey,
       sndSecure = False
     }
@@ -225,23 +225,23 @@ connectionRequestTests =
       queueV1NoPort #== ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
       queueV1NoPort #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#" <> testDhKeyStr)
     it "should serialize and parse connection invitations and contact addresses" $ do
-      connectionRequest #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequest #== ("https://simplex.chat/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequestSK #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequest1 #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequest2queues #==# ("simplex:/invitation#/?v=2-7&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequestNew #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequestNew1 #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueNew1Str <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequest2queuesNew #==# ("simplex:/invitation#/?v=2-7&smp=" <> url (queueNewStr <> ";" <> queueNewStr) <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequest #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequest #== ("https://simplex.chat/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequestSK #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequest1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequest2queues #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequestNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequestNew1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNew1Str <> "&e2e=" <> testE2ERatchetParamsStrUri)
+      connectionRequest2queuesNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr) <> "&e2e=" <> testE2ERatchetParamsStrUri)
       connectionRequestV1 #== ("https://simplex.chat/invitation#/?v=1&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
-      connectionRequestClientDataEmpty #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri <> "&data=" <> url "{}")
-      contactAddress #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueStr)
-      contactAddress #== ("https://simplex.chat/contact#/?v=2-7&smp=" <> url queueStr)
-      contactAddress2queues #==# ("simplex:/contact#/?v=2-7&smp=" <> url (queueStr <> ";" <> queueStr))
-      contactAddressNew #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueNewStr)
-      contactAddress2queuesNew #==# ("simplex:/contact#/?v=2-7&smp=" <> url (queueNewStr <> ";" <> queueNewStr))
+      connectionRequestClientDataEmpty #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri <> "&data=" <> url "{}")
+      contactAddress #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr)
+      contactAddress #== ("https://simplex.chat/contact#/?v=2-6&smp=" <> url queueStr)
+      contactAddress2queues #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr))
+      contactAddressNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueNewStr)
+      contactAddress2queuesNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr))
       contactAddressV2 #==# ("simplex:/contact#/?v=2&smp=" <> url queueStr)
       contactAddressV2 #== ("https://simplex.chat/contact#/?v=1&smp=" <> url queueStr) -- adjusted to v2
       contactAddressV2 #== ("https://simplex.chat/contact#/?v=1-2&smp=" <> url queueStr) -- adjusted to v2
       contactAddressV2 #== ("https://simplex.chat/contact#/?v=2-2&smp=" <> url queueStr)
-      contactAddressClientData #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}")
+      contactAddressClientData #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}")

tests/AgentTests/FunctionalAPITests.hs

@@ -38,7 +38,6 @@ module AgentTests.FunctionalAPITests
     rfGet,
     sfGet,
     nGet,
-    getInAnyOrder,
     (##>),
     (=##>),
     pattern CON,
@@ -245,7 +244,7 @@ inAnyOrder g rs = withFrozenCallStack $ do
 createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
 createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn)
 
-joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
+joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE ConnId
 joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId Nothing enableNtfs cReq connInfo PQSupportOn
 
 sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId
@@ -270,22 +269,19 @@ functionalAPITests t = do
     describe "two way concurrently (50)" $ testMatrix2Stress t $ runAgentClientStressTestConc 25
     xdescribe "two way concurrently (1000)" $ testMatrix2Stress t $ runAgentClientStressTestConc 500
   describe "Establishing duplex connection, different PQ settings" $ do
-    testPQMatrix2 t $ runAgentClientTestPQ False True
+    testPQMatrix2 t $ runAgentClientTestPQ True
   describe "Establishing duplex connection v2, different Ratchet versions" $
     testRatchetMatrix2 t runAgentClientTest
   describe "Establish duplex connection via contact address" $
     testMatrix2 t runAgentClientContactTest
   describe "Establish duplex connection via contact address, different PQ settings" $ do
-    testPQMatrix2NoInv t $ runAgentClientContactTestPQ False True PQSupportOn
+    testPQMatrix2NoInv t $ runAgentClientContactTestPQ True PQSupportOn
   describe "Establish duplex connection via contact address v2, different Ratchet versions" $
     testRatchetMatrix2 t runAgentClientContactTest
   describe "Establish duplex connection via contact address, different PQ settings" $ do
     testPQMatrix3 t $ runAgentClientContactTestPQ3 True
   it "should support rejecting contact request" $
     withSmpServer t testRejectContactRequest
-  describe "Changing connection user id" $ do
-    it "should change user id for new connections" $ do
-      withSmpServer t testUpdateConnectionUserId
   describe "Establishing connection asynchronously" $ do
     it "should connect with initiating client going offline" $
       withSmpServer t testAsyncInitiatingOffline
@@ -360,9 +356,6 @@ functionalAPITests t = do
     it "should subscribe to multiple connections with pending messages" $
       withSmpServer t $
         testBatchedPendingMessages 10 5
-  describe "Batch send messages" $ do
-    it "should send multiple messages to the same connection" $ withSmpServer t testSendMessagesB
-    it "should send messages to the 2 connections" $ withSmpServer t testSendMessagesB2
   describe "Async agent commands" $ do
     describe "connect using async agent commands" $
       testBasicMatrix2 t testAsyncCommands
@@ -417,30 +410,29 @@ functionalAPITests t = do
     let v4 = prevVersion basicAuthSMPVersion
     forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do
       let baseId = if v >= sndAuthKeySMPVersion then 1 else 3
-          sqSecured = if v >= sndAuthKeySMPVersion then True else False
       describe ("v" <> show v <> ": with server auth") $ do
         --                                       allow NEW | server auth, v | clnt1 auth, v  | clnt2 auth, v    |  2 - success, 1 - JOIN fail, 0 - NEW fail
-        it "success                " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
-        it "disabled               " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
-        it "NEW fail, no auth      " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
-        it "NEW fail, bad auth     " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
-        it "NEW fail, version      " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
-        it "JOIN fail, no auth     " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1
-        it "JOIN fail, bad auth    " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1
-        it "JOIN fail, version     " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) sqSecured baseId `shouldReturn` 1
+        it "success                " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2
+        it "disabled               " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0
+        it "NEW fail, no auth      " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 0
+        it "NEW fail, bad auth     " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) baseId `shouldReturn` 0
+        it "NEW fail, version      " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) baseId `shouldReturn` 0
+        it "JOIN fail, no auth     " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 1
+        it "JOIN fail, bad auth    " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) baseId `shouldReturn` 1
+        it "JOIN fail, version     " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) baseId `shouldReturn` 1
       describe ("v" <> show v <> ": no server auth") $ do
-        it "success     " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2
-        it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0
-        it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) False 3 `shouldReturn` 2
-        it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) False baseId `shouldReturn` 2
-        it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) sqSecured 3 `shouldReturn` 2
-        it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) False 3 `shouldReturn` 2
-        it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) False 3 `shouldReturn` 2
-        it "auth fst    " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2
-        it "auth fst 2  " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) False 3 `shouldReturn` 2
-        it "auth snd    " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
-        it "auth both   " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
-        it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
+        it "success     " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 2
+        it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 0
+        it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) 3 `shouldReturn` 2
+        it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) baseId `shouldReturn` 2
+        it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) 3 `shouldReturn` 2
+        it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2
+        it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2
+        it "auth fst    " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 2
+        it "auth fst 2  " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) 3 `shouldReturn` 2
+        it "auth snd    " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 2
+        it "auth both   " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2
+        it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0
   describe "SMP server test via agent API" $ do
     it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
     let srv1 = testSMPServer2 {keyHash = "1234"}
@@ -468,8 +460,8 @@ functionalAPITests t = do
     it "server should respond with queue and subscription information" $
       withSmpServer t testServerQueueInfo
 
-testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
-testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do
+testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int
+testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 baseId = do
   let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange batchCmdsSMPVersion srvVersion}
       canCreate1 = canCreateQueue allowNewQueues srv clnt1
       canCreate2 = canCreateQueue allowNewQueues srv clnt2
@@ -477,7 +469,7 @@ testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured b
         | canCreate1 && canCreate2 = 2
         | canCreate1 = 1
         | otherwise = 0
-  created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId
+  created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 baseId
   created `shouldBe` expected
   pure created
 
@@ -486,43 +478,43 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
   let v = basicAuthSMPVersion
    in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth))
 
-testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2 t runTest = do
-  it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True
-  it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True
-  it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False
-  it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False False
-  it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False False
-  it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False False
+  it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True
+  it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
+  it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False
+  it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False
+  it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False
+  it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False
 
-testMatrix2Stress :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testMatrix2Stress :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testMatrix2Stress t runTest = do
-  it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True
-  it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True
-  it "current" $ withSmpServer t $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False
-  it "prev" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False False
-  it "prev to current" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False False
-  it "current to prev" $ withSmpServer t $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False False
+  it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True
+  it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
+  it "current" $ withSmpServer t $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn False
+  it "prev" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False
+  it "prev to current" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False
+  it "current to prev" $ withSmpServer t $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False
   where
     aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval}
     aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval}
     aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval}
 
-testBasicMatrix2 :: HasCallStack => ATransport -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testBasicMatrix2 :: HasCallStack => ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testBasicMatrix2 t runTest = do
-  it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest True
-  it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest False
-  it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest False
-  it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest False
+  it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest
+  it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest
+  it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest
+  it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest
 
-testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
+testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
 testRatchetMatrix2 t runTest = do
-  it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True
-  it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True
-  it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False
-  it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False
-  it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False
-  it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False
+  it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True
+  it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
+  it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False
+  it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff False
+  it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff False
+  it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff False
 
 testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec
 testServerMatrix2 t runTest = do
@@ -597,16 +589,15 @@ withAgentClients3 runTest =
     withAgent 3 agentCfg initAgentServers testDB3 $ \c ->
       runTest a b c
 
-runAgentClientTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
-runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
-  runAgentClientTestPQ sqSecured viaProxy (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
+runAgentClientTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientTest pqSupport viaProxy alice bob baseId =
+  runAgentClientTestPQ viaProxy (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
 
-runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
-runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
+runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
+runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
     (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe
-    (aliceId, sqSecured') <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe
-    liftIO $ sqSecured' `shouldBe` sqSecured
+    aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
     allowConnection alice bobId confId "alice's connInfo"
@@ -643,10 +634,10 @@ runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
 pqConnectionMode :: InitialKeys -> PQSupport -> Bool
 pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
 
-runAgentClientStressTestOneWay :: HasCallStack => Int64 -> PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
-runAgentClientStressTestOneWay n pqSupport sqSecured viaProxy alice bob baseId = runRight_ $ do
+runAgentClientStressTestOneWay :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientStressTestOneWay n pqSupport viaProxy alice bob baseId = runRight_ $ do
   let pqEnc = PQEncryption $ supportPQ pqSupport
-  (aliceId, bobId) <- makeConnection_ pqSupport sqSecured alice bob
+  (aliceId, bobId) <- makeConnection_ pqSupport alice bob
   let proxySrv = if viaProxy then Just testSMPServer else Nothing
       message i = "message " <> bshow i
   concurrently_
@@ -675,10 +666,10 @@ runAgentClientStressTestOneWay n pqSupport sqSecured viaProxy alice bob baseId =
   where
     msgId = subtract baseId . fst
 
-runAgentClientStressTestConc :: HasCallStack => Int64 -> PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
-runAgentClientStressTestConc n pqSupport sqSecured viaProxy alice bob baseId = runRight_ $ do
+runAgentClientStressTestConc :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientStressTestConc n pqSupport viaProxy alice bob baseId = runRight_ $ do
   let pqEnc = PQEncryption $ supportPQ pqSupport
-  (aliceId, bobId) <- makeConnection_ pqSupport sqSecured alice bob
+  (aliceId, bobId) <- makeConnection_ pqSupport alice bob
   let proxySrv = if viaProxy then Just testSMPServer else Nothing
       message i = "message " <> bshow i
       loop a bId mIdVar i = do
@@ -712,7 +703,7 @@ testEnablePQEncryption :: HasCallStack => IO ()
 testEnablePQEncryption =
   withAgentClients2 $ \ca cb -> runRight_ $ do
     g <- liftIO C.newRandom
-    (aId, bId) <- makeConnection_ PQSupportOff True ca cb
+    (aId, bId) <- makeConnection_ PQSupportOff ca cb
     let a = (ca, aId)
         b = (cb, bId)
     (a, 2, "msg 1") \#>\ b
@@ -798,23 +789,20 @@ testAgentClient3 =
     get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False
     ackMessage c aIdForC 3 Nothing
 
-runAgentClientContactTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
-runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
-  runAgentClientContactTestPQ sqSecured viaProxy pqSupport (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
+runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
+runAgentClientContactTest pqSupport viaProxy alice bob baseId =
+  runAgentClientContactTestPQ viaProxy pqSupport (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
 
-runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
-runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
+runAgentClientContactTestPQ :: HasCallStack => Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
+runAgentClientContactTestPQ viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
     (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
-    (aliceId', sqSecuredJoin) <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecuredJoin `shouldBe` False -- joining via contact address connection
+    aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe
+    liftIO $ aliceId' `shouldBe` aliceId
     ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
     liftIO $ pqSup' `shouldBe` reqPQSupport
-    (bobId, sqSecured') <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
-    liftIO $ sqSecured' `shouldBe` sqSecured
+    bobId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
     ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
     liftIO $ pqSup'' `shouldBe` bPQ
     allowConnection bob aliceId confId "bob's connInfo"
@@ -859,14 +847,11 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
     msgId = subtract baseId . fst
     connectViaContact b pq qInfo = do
       aId <- A.prepareConnectionToJoin b 1 True qInfo pq
-      (aId', sqSecuredJoin) <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe
-      liftIO $ do
-        aId' `shouldBe` aId
-        sqSecuredJoin `shouldBe` False -- joining via contact address connection
+      aId' <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe
+      liftIO $ aId' `shouldBe` aId
       ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
-      (bId, sqSecuredAccept) <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
-      liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
+      bId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
       ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
       liftIO $ pqSup'' `shouldBe` pq
       allowConnection b aId confId "bob's connInfo"
@@ -906,68 +891,28 @@ testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     (addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe
     aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    (aliceId', sqSecured) <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecured `shouldBe` False -- joining via contact address connection
+    aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+    liftIO $ aliceId' `shouldBe` aliceId
     ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
     liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
     rejectContact alice addrConnId invId
     liftIO $ noMessages bob "nothing delivered to bob"
 
-testUpdateConnectionUserId :: HasCallStack => IO ()
-testUpdateConnectionUserId =
-  withAgentClients2 $ \alice bob -> runRight_ $ do
-    (connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
-    _ <- changeConnectionUser alice 1 connId newUserId
-    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
-    (aliceId', sqSecured') <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecured' `shouldBe` True
-    ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
-    liftIO $ pqSup' `shouldBe` PQSupportOn
-    allowConnection alice connId confId "alice's connInfo"
-    let pqEnc = CR.pqSupportToEnc PQSupportOn
-    get alice ##> ("", connId, A.CON pqEnc)
-    get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
-    get bob ##> ("", aliceId, A.CON pqEnc)
-
 testAsyncInitiatingOffline :: HasCallStack => IO ()
 testAsyncInitiatingOffline =
   withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do
     alice <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     liftIO $ disposeAgentClient alice
-
-    (aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
-
-    -- send messages
-    msgId1 <- A.sendMessage bob aliceId PQEncOn SMP.noMsgFlags "can send 1"
-    liftIO $ msgId1 `shouldBe` (2, PQEncOff)
-    get bob ##> ("", aliceId, SENT 2)
-    msgId2 <- A.sendMessage bob aliceId PQEncOn SMP.noMsgFlags "can send 2"
-    liftIO $ msgId2 `shouldBe` (3, PQEncOff)
-    get bob ##> ("", aliceId, SENT 3)
-
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     alice' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB
     subscribeConnection alice' bobId
     ("", _, CONF confId _ "bob's connInfo") <- get alice'
-    -- receive messages
-    get alice' =##> \case ("", c, Msg' mId pq "can send 1") -> c == bobId && mId == 1 && pq == PQEncOff; _ -> False
-    ackMessage alice' bobId 1 Nothing
-    get alice' =##> \case ("", c, Msg' mId pq "can send 2") -> c == bobId && mId == 2 && pq == PQEncOff; _ -> False
-    ackMessage alice' bobId 2 Nothing
-    -- for alice msg id 3 is sent confirmation, then they're matched with bob at msg id 4
-
-    -- allow connection
     allowConnection alice' bobId confId "alice's connInfo"
     get alice' ##> ("", bobId, CON)
     get bob ##> ("", aliceId, INFO "alice's connInfo")
     get bob ##> ("", aliceId, CON)
-    exchangeGreetingsMsgId 4 alice' bobId bob aliceId
+    exchangeGreetings alice' bobId bob aliceId
     liftIO $ disposeAgentClient alice'
 
 testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO ()
@@ -975,8 +920,7 @@ testAsyncJoiningOfflineBeforeActivation =
   withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight_ $ do
     bob <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB2
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     liftIO $ disposeAgentClient bob
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
@@ -995,8 +939,7 @@ testAsyncBothOffline = do
   runRight_ $ do
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     liftIO $ disposeAgentClient alice
-    (aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     liftIO $ disposeAgentClient bob
     alice' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB
     subscribeConnection alice' bobId
@@ -1027,8 +970,7 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do
     liftIO $ do
       srv1 `shouldBe` testSMPServer
       conns1 `shouldBe` [bobId]
-    (aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
@@ -1046,8 +988,7 @@ testAllowConnectionClientRestart t = do
       withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do
         runRight $ do
           (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-          (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
-          liftIO $ sqSecured `shouldBe` True
+          aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
           ("", _, CONF confId _ "bob's connInfo") <- get alice
           pure (aliceId, bobId, confId)
 
@@ -1063,12 +1004,13 @@ 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)
@@ -1082,7 +1024,7 @@ testIncreaseConnAgentVersion t = do
   bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ do
-      (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob
+      (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
       exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId
       checkVersion alice bobId 2
       checkVersion bob aliceId 2
@@ -1147,7 +1089,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do
   bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ do
-      (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob
+      (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
       exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId
       checkVersion alice bobId 2
       checkVersion bob aliceId 2
@@ -1177,7 +1119,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do
   bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aliceId, bobId) <- runRight $ do
-      (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob
+      (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
       exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId
       checkVersion alice bobId 2
       checkVersion bob aliceId 2
@@ -1678,8 +1620,7 @@ testRatchetSyncSimultaneous t = do
 testOnlyCreatePullSlowHandshake :: IO ()
 testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProxyCfgV8 $ \alice bob -> runRight_ $ do
   (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate
-  (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
-  liftIO $ sqSecured `shouldBe` False
+  aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
   Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
@@ -1713,8 +1654,7 @@ getMsg c cId action = do
 testOnlyCreatePull :: IO ()
 testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate
-  (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
-  liftIO $ sqSecured `shouldBe` True
+  aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
   Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
   allowConnection alice bobId confId "alice's connInfo"
   liftIO $ threadDelay 1_000000
@@ -1736,22 +1676,20 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
   ackMessage alice bobId 3 Nothing
 
 makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
-makeConnection = makeConnection_ PQSupportOn True
+makeConnection = makeConnection_ PQSupportOn
 
-makeConnection_ :: PQSupport -> SndQueueSecured -> AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
-makeConnection_ pqEnc sqSecured alice bob = makeConnectionForUsers_ pqEnc sqSecured alice 1 bob 1
+makeConnection_ :: PQSupport -> AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
+makeConnection_ pqEnc alice bob = makeConnectionForUsers_ pqEnc alice 1 bob 1
 
 makeConnectionForUsers :: HasCallStack => AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
-makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
+makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn
 
-makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
-makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
+makeConnectionForUsers_ :: HasCallStack => PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
+makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do
   (bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
-  (aliceId', sqSecured') <- A.joinConnection bob bobUserId (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
-  liftIO $ do
-    aliceId' `shouldBe` aliceId
-    sqSecured' `shouldBe` sqSecured
+  aliceId' <- A.joinConnection bob bobUserId (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
+  liftIO $ aliceId' `shouldBe` aliceId
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
   liftIO $ pqSup' `shouldBe` pqSupport
   allowConnection alice bobId confId "alice's connInfo"
@@ -1834,6 +1772,7 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do
     get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
     ackMessage b aId 2 Nothing
     pure (aId, bId)
+
   runRight_ $ do
     ("", "", DOWN {}) <- nGet a
     ("", "", DOWN {}) <- nGet b
@@ -1841,17 +1780,15 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do
     4 <- sendMessage b aId SMP.noMsgFlags "how are you?"
     liftIO $ threadDelay 100000
     liftIO $ suspendAgent b 5000000
+
   withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do
-    -- there will be no UP event for b, because re-subscriptions are suspended until the agent is in foreground
-    get b =##> \case ("", c, SENT 3) -> c == aId; _ -> False
-    get b =##> \case ("", c, SENT 4) -> c == aId; _ -> False
-    nGet b ##> ("", "", SUSPENDED)
-    liftIO $
-      getInAnyOrder
-        a
-        [ \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; _ -> False,
-          \case ("", "", AEvt _ UP {}) -> True; _ -> False
-        ]
+    pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
+    pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
+    pGet b =##> \case ("", c, AEvt SAEConn (SENT 4)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
+    ("", "", SUSPENDED) <- nGet b
+
+    pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False
+    pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False
     ackMessage a bId 3 Nothing
     get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
     ackMessage a bId 4 Nothing
@@ -1879,7 +1816,7 @@ testBatchedSubscriptions :: Int -> Int -> ATransport -> IO ()
 testBatchedSubscriptions nCreate nDel t =
   withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
     conns <- runServers $ do
-      conns <- replicateM nCreate $ makeConnection_ PQSupportOff True a b
+      conns <- replicateM nCreate $ makeConnection_ PQSupportOff a b
       forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId
       let (aIds', bIds') = unzip $ take nDel conns
       delete a bIds'
@@ -1957,59 +1894,15 @@ testBatchedPendingMessages nCreate nMsgs =
     withA = withAgent 1 agentCfg initAgentServers testDB
     withB = withAgent 2 agentCfg initAgentServers testDB2
 
-testSendMessagesB :: IO ()
-testSendMessagesB = withAgentClients2 $ \a b -> runRight_ $ do
-  (aId, bId) <- makeConnection a b
-  let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, body)
-  [SentB 2, SentB 3, SentB 4] <- sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3"] :: [Either AgentErrorType MsgReq])
-  get a ##> ("", bId, SENT 2)
-  get a ##> ("", bId, SENT 3)
-  get a ##> ("", bId, SENT 4)
-  receiveMsg b aId 2 "msg 1"
-  receiveMsg b aId 3 "msg 2"
-  receiveMsg b aId 4 "msg 3"
-
-testSendMessagesB2 :: IO ()
-testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do
-  (abId, bId) <- makeConnection a b
-  (acId, cId) <- makeConnection a c
-  let msg connId body = Right (connId, PQEncOn, SMP.noMsgFlags, body)
-  [SentB 2, SentB 3, SentB 4, SentB 2, SentB 3] <-
-    sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3", msg cId "msg 4", msg "" "msg 5"] :: [Either AgentErrorType MsgReq])
-  liftIO $
-    getInAnyOrder
-      a
-      [ \case ("", cId', AEvt SAEConn (SENT 2)) -> cId' == bId; _ -> False,
-        \case ("", cId', AEvt SAEConn (SENT 3)) -> cId' == bId; _ -> False,
-        \case ("", cId', AEvt SAEConn (SENT 4)) -> cId' == bId; _ -> False,
-        \case ("", cId', AEvt SAEConn (SENT 2)) -> cId' == cId; _ -> False,
-        \case ("", cId', AEvt SAEConn (SENT 3)) -> cId' == cId; _ -> False
-      ]
-  receiveMsg b abId 2 "msg 1"
-  receiveMsg b abId 3 "msg 2"
-  receiveMsg b abId 4 "msg 3"
-  receiveMsg c acId 2 "msg 4"
-  receiveMsg c acId 3 "msg 5"
-
-pattern SentB :: AgentMsgId -> Either AgentErrorType (AgentMsgId, PQEncryption)
-pattern SentB msgId <- Right (msgId, PQEncOn)
-
-receiveMsg :: AgentClient -> ConnId -> AgentMsgId -> MsgBody -> ExceptT AgentErrorType IO ()
-receiveMsg c cId msgId msg  = do
-  get c =##> \case ("", cId', Msg' mId' PQEncOn msg') -> cId' == cId && mId' == msgId && msg' == msg; _ -> False
-  ackMessage c cId msgId Nothing
-
-testAsyncCommands :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
-testAsyncCommands sqSecured alice bob baseId =
+testAsyncCommands :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
+testAsyncCommands alice bob baseId =
   runRight_ $ do
     bobId <- createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe
     ("1", bobId', INV (ACR _ qInfo)) <- get alice
     liftIO $ bobId' `shouldBe` bobId
     aliceId <- joinConnectionAsync bob 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-    ("2", aliceId', JOINED sqSecured') <- get bob
-    liftIO $ do
-      aliceId' `shouldBe` aliceId
-      sqSecured' `shouldBe` sqSecured
+    ("2", aliceId', OK) <- get bob
+    liftIO $ aliceId' `shouldBe` aliceId
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnectionAsync alice "3" bobId confId "alice's connInfo"
     get alice =##> \case ("3", _, OK) -> True; _ -> False
@@ -2062,15 +1955,14 @@ testAsyncCommandsRestore t = do
       get alice' =##> \case ("1", _, INV _) -> True; _ -> False
       pure ()
 
-testAcceptContactAsync :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
-testAcceptContactAsync sqSecured alice bob baseId =
+testAcceptContactAsync :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
+testAcceptContactAsync alice bob baseId =
   runRight_ $ do
     (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe
-    (aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
-    liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     ("", _, REQ invId _ "bob's connInfo") <- get alice
     bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
-    get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == sqSecured; _ -> False
+    get alice =##> \case ("1", c, OK) -> c == bobId; _ -> False
     ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
     get alice ##> ("", bobId, INFO "bob's connInfo")
@@ -2346,7 +2238,7 @@ testJoinConnectionAsyncReplyErrorV8 t = do
         pure (aId, bId)
       nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
       withSmpServerOn t testPort2 $ do
-        get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False
+        get b =##> \case ("2", c, OK) -> c == aId; _ -> False
         confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
           pGet a >>= \case
             ("", "", AEvt _ (UP _ [_])) -> do
@@ -2387,7 +2279,7 @@ testJoinConnectionAsyncReplyError t = do
       withSmpServerOn t testPort2 $ do
         confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
           -- both servers need to be online for connection to progress because of SKEY
-          get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False
+          get b =##> \case ("2", c, OK) -> c == aId; _ -> False
           pGet a >>= \case
             ("", "", AEvt _ (UP _ [_])) -> do
               ("", _, CONF confId _ "bob's connInfo") <- get a
@@ -2841,8 +2733,8 @@ testSwitch2ConnectionsAbort1 servers = do
     withB :: (AgentClient -> IO a) -> IO a
     withB = withAgent 2 agentCfg servers testDB2
 
-testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
-testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
+testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int
+testCreateQueueAuth srvVersion clnt1 clnt2 baseId = do
   a <- getClient 1 clnt1 testDB
   b <- getClient 2 clnt2 testDB2
   r <- runRight $ do
@@ -2853,8 +2745,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
         tryError (joinConnection b 1 True qInfo "bob's connInfo" SMSubscribe) >>= \case
           Left (SMP _ AUTH) -> pure 1
           Left e -> throwError e
-          Right (aId, sqSecured') -> do
-            liftIO $ sqSecured' `shouldBe` sqSecured
+          Right aId -> do
             ("", _, CONF confId _ "bob's connInfo") <- get a
             allowConnection a bId confId "alice's connInfo"
             get a ##> ("", bId, CON)
@@ -2914,7 +2805,7 @@ testDeliveryReceiptsVersion t = do
   b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
   withSmpServerStoreMsgLogOn t testPort $ \_ -> do
     (aId, bId) <- runRight $ do
-      (aId, bId) <- makeConnection_ PQSupportOff False a b
+      (aId, bId) <- makeConnection_ PQSupportOff a b
       checkVersion a bId 3
       checkVersion b aId 3
       (2, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello"
@@ -2938,8 +2829,8 @@ testDeliveryReceiptsVersion t = do
       subscribeConnection a' bId
       subscribeConnection b' aId
       exchangeGreetingsMsgId_ PQEncOff 4 a' bId b' aId
-      checkVersion a' bId 7
-      checkVersion b' aId 7
+      checkVersion a' bId 6
+      checkVersion b' aId 6
       (6, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello"
       get a' ##> ("", bId, SENT 6)
       get b' =##> \case ("", c, Msg' 6 PQEncOff "hello") -> c == aId; _ -> False
@@ -3088,8 +2979,7 @@ testServerMultipleIdentities :: HasCallStack => IO ()
 testServerMultipleIdentities =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    (aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get alice ##> ("", bobId, CON)
@@ -3188,8 +3078,7 @@ testServerQueueInfo = do
     (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     liftIO $ threadDelay 200000
     checkEmptyQ alice bobId False
-    (aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     liftIO $ threadDelay 200000
     checkEmptyQ alice bobId True -- secured by sender

tests/AgentTests/NotificationTests.hs

@@ -49,7 +49,6 @@ import Data.Bifunctor (bimap, first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import qualified Data.List.NonEmpty as L
 import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple.QQ (sql)
 import NtfClient
@@ -67,7 +66,6 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..))
-import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
@@ -166,7 +164,7 @@ testNtfMatrix t runTest = do
     it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest
     it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
     it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
-    it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
+    it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
     -- servers can be upgraded in any order
     it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
     it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
@@ -479,7 +477,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
   (bobId, aliceId, nonce, message) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    (aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -509,16 +507,14 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
   threadDelay 500000
   suspendAgent alice 0
   closeSQLiteStore store
-  threadDelay 1000000
-  putStrLn "before opening the database from another agent"
+  threadDelay 500000
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
   withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
-    (_, Just SMPMsgMeta {msgFlags = MsgFlags True}) <- getNotificationMessage aliceNtf nonce message
+    (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
     pure ()
 
-  threadDelay 1000000
-  putStrLn "after closing the database in another agent"
+  threadDelay 500000
   reopenSQLiteStore store
   foregroundAgent alice
   threadDelay 500000
@@ -528,7 +524,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId ali
     ackMessage alice bobId (baseId + 1) Nothing
     -- delete notification subscription
     toggleConnectionNtfs alice bobId False
-    liftIO $ threadDelay 500000
+    liftIO $ threadDelay 250000
     -- send message
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
@@ -548,7 +544,7 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bo
     liftIO $ threadDelay 50000
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     liftIO $ threadDelay 1000000
-    (aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     liftIO $ threadDelay 750000
     void $ messageNotificationData alice apnsQ
     ("", _, CONF confId _ "bob's connInfo") <- get alice
@@ -595,8 +591,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -658,8 +653,7 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t
   (aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
-    (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
-    liftIO $ sqSecured `shouldBe` True
+    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     allowConnection alice bobId confId "alice's connInfo"
     get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -874,8 +868,8 @@ messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockReques
 messageNotificationData c apnsQ = do
   (nonce, message) <- messageNotification apnsQ
   NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
-  Right pnMsgs <- liftEither . first INTERNAL $ Right . parseAll pnMessagesP =<< first show (C.cbDecrypt dhSecret nonce message)
-  pure $ L.last pnMsgs
+  Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message)
+  pure pnMsgData
 
 noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
 noNotification apnsQ = do

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

tests/CoreTests/BatchingTests.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -41,7 +40,6 @@ 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
 
@@ -167,20 +165,6 @@ 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
@@ -277,7 +261,7 @@ testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
 testClientStub = do
   g <- C.newRandom
   sessId <- atomically $ C.randomBytes 32 g
-  smpClientStub g sessId subModeSMPVersion Nothing
+  atomically $ smpClientStub g sessId subModeSMPVersion Nothing
 
 clientStubV7 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
 clientStubV7 = do
@@ -285,7 +269,7 @@ clientStubV7 = do
   sessId <- atomically $ C.randomBytes 32 g
   (rKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
   thAuth_ <- testTHandleAuth authCmdsSMPVersion g rKey
-  smpClientStub g sessId authCmdsSMPVersion thAuth_
+  atomically $ smpClientStub g sessId authCmdsSMPVersion thAuth_
 
 randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
 randomSUB = randomSUB_ C.SEd25519 subModeSMPVersion
@@ -301,7 +285,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, EntityId rId, Cmd SRecipient SUB)
+      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, rId, Cmd SRecipient SUB)
   pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth
 
 randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
@@ -315,13 +299,7 @@ randomSUBCmd_ a c = do
   g <- C.newRandom
   rId <- atomically $ C.randomBytes 24 g
   (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
-  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)
+  mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB)
 
 randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
 randomSEND = randomSEND_ C.SEd25519 subModeSMPVersion
@@ -338,7 +316,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, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
+      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
   pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) nonce tForAuth
 
 testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient
@@ -377,7 +355,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, EntityId sId, Cmd SSender $ SEND noMsgFlags msg)
+  mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg)
 
 lenOk :: ByteString -> Bool
 lenOk s = 0 < B.length s && B.length s <= smpBlockSize - 2

tests/CoreTests/RetryIntervalTests.hs

@@ -2,8 +2,6 @@
 
 module CoreTests.RetryIntervalTests where
 
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Monad (when)
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
@@ -15,10 +13,6 @@ retryIntervalTests = do
   describe "Retry interval with 2 modes and lock" $ do
     testRetryIntervalSameMode
     testRetryIntervalSwitchMode
-  describe "Foreground retry interval" $ do 
-    testRetryForeground
-    testRetryToBackground
-    testRetrySkipWhenForeground
 
 testRI :: RetryInterval2
 testRI =
@@ -29,15 +23,12 @@ testRI =
             increaseAfter = 40000,
             maxInterval = 40000
           },
-      riFast = testFastRI
-    }
-
-testFastRI :: RetryInterval
-testFastRI =
-  RetryInterval
-    { initialInterval = 10000,
-      increaseAfter = 20000,
-      maxInterval = 40000
+      riFast =
+        RetryInterval
+          { initialInterval = 10000,
+            increaseAfter = 20000,
+            maxInterval = 40000
+          }
     }
 
 testRetryIntervalSameMode :: Spec
@@ -90,67 +81,6 @@ testRetryIntervalSwitchMode =
                        (40000, 40000)
                      ]
 
-testRetryForeground :: Spec
-testRetryForeground =
-  it "should increase elapased time and interval" $ do
-    intervals <- newTVarIO []
-    reportedIntervals <- newTVarIO []
-    ts <- newTVarIO =<< getCurrentTime
-    let isForeground = pure True
-    withRetryForeground testFastRI isForeground (pure True) $ \delay loop -> do
-      ints <- addInterval intervals ts
-      atomically $ modifyTVar' reportedIntervals (delay :)
-      when (length ints < 8) $ loop
-    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
-    (reverse <$> readTVarIO reportedIntervals)
-      `shouldReturn` [ 10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
-
-testRetryToBackground :: Spec
-testRetryToBackground =
-  it "should not change interval when moving to background" $ do
-    intervals <- newTVarIO []
-    reportedIntervals <- newTVarIO []
-    ts <- newTVarIO =<< getCurrentTime
-    foreground <- newTVarIO True
-    concurrently_
-      ( do
-          threadDelay 50000
-          atomically $ writeTVar foreground False
-      )
-      ( withRetryForeground testFastRI (readTVar foreground) (pure True) $ \delay loop -> do
-          ints <- addInterval intervals ts
-          atomically $ modifyTVar' reportedIntervals (delay :)
-          when (length ints < 8) $ loop
-      )
-    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
-    (reverse <$> readTVarIO reportedIntervals)
-      `shouldReturn` [ 10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
-
-testRetrySkipWhenForeground :: Spec
-testRetrySkipWhenForeground =
-  it "should repeat loop as soon as moving to foreground" $ do
-    intervals <- newTVarIO []
-    reportedIntervals <- newTVarIO []
-    ts <- newTVarIO =<< getCurrentTime
-    foreground <- newTVarIO False
-    concurrently_
-      ( do
-          threadDelay 65000
-          atomically $ writeTVar foreground True
-          threadDelay 10000
-          atomically $ writeTVar foreground False
-          threadDelay 100000
-          atomically $ writeTVar foreground True
-      )
-      ( withRetryForeground testFastRI (readTVar foreground) (pure True) $ \delay loop -> do
-          ints <- addInterval intervals ts
-          atomically $ modifyTVar' reportedIntervals (delay :)
-          when (length ints < 12) $ loop
-      )
-    (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 0, 1, 1, 1, 2, 3, 1]
-    (reverse <$> readTVarIO reportedIntervals)
-      `shouldReturn` [ 10000, 10000, 15000, 22500, 33750, 10000, 10000, 15000, 22500, 33750, 40000, 10000]
-
 addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
 addInterval intervals ts = do
   ts' <- getCurrentTime

tests/CoreTests/TRcvQueuesTests.hs

@@ -1,23 +1,19 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# 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 (EntityId (..), RecipientId, SMPServer, pattern NoEntity, pattern VersionSMPC)
+import Simplex.Messaging.Protocol (SMPServer, pattern VersionSMPC)
 import Test.Hspec
 import UnliftIO
 
@@ -34,26 +30,24 @@ 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 :: RQ.TRcvQueues -> IO Bool
 checkDataInvariant trq = atomically $ do
   conns <- readTVar $ RQ.getConnections trq
   qs <- readTVar $ RQ.getRcvQueues trq
   -- three invariant checks
-  let inv1 = all (\cId -> (S.fromList . L.toList <$> M.lookup cId conns) == Just (M.keysSet (M.filter (\q -> RQ.connId' q == cId) qs))) (M.keys conns)
-      inv2 = all (\(k, q) -> maybe False ((k `elem`) . L.toList) (M.lookup (RQ.connId' q) conns)) (M.assocs qs)
+  let inv1 = all (\cId -> (S.fromList . L.toList <$> M.lookup cId conns) == Just (M.keysSet (M.filter (\q -> connId q == cId) qs))) (M.keys conns)
+      inv2 = all (\(k, q) -> maybe False ((k `elem`) . L.toList) (M.lookup (connId q) conns)) (M.assocs qs)
       inv3 = all (\(k, q) -> RQ.qKey q == k) (M.assocs qs)
   pure $ inv1 && inv2 && inv3
 
 hasConnTest :: IO ()
 hasConnTest = do
-  trq <- RQ.empty
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
+  trq <- atomically RQ.empty
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
   checkDataInvariant trq `shouldReturn` True
   atomically (RQ.hasConn "c1" trq) `shouldReturn` True
   atomically (RQ.hasConn "c2" trq) `shouldReturn` True
@@ -62,8 +56,8 @@ hasConnTest = do
 
 hasConnTestBatch :: IO ()
 hasConnTestBatch = do
-  trq <- RQ.empty
-  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"]
+  trq <- atomically 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"]
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
   atomically (RQ.hasConn "c1" trq) `shouldReturn` True
@@ -73,8 +67,8 @@ hasConnTestBatch = do
 
 batchIdempotentTest :: IO ()
 batchIdempotentTest = do
-  trq <- RQ.empty
-  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"]
+  trq <- atomically 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"]
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
   qs' <- readTVarIO $ RQ.getRcvQueues trq
@@ -82,15 +76,15 @@ batchIdempotentTest = do
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
   readTVarIO (RQ.getRcvQueues trq) `shouldReturn` qs'
-  fmap L.nub <$> readTVarIO (RQ.getConnections trq) `shouldReturn` cs' -- connections get duplicated, but that doesn't appear to affect anybody
+  fmap L.nub <$> readTVarIO (RQ.getConnections trq) `shouldReturn`cs' -- connections get duplicated, but that doesn't appear to affect anybody
 
 deleteConnTest :: IO ()
 deleteConnTest = do
-  trq <- RQ.empty
+  trq <- atomically RQ.empty
   atomically $ do
-    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
+    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
   checkDataInvariant trq `shouldReturn` True
   atomically $ RQ.deleteConn "c1" trq
   checkDataInvariant trq `shouldReturn` True
@@ -100,49 +94,41 @@ deleteConnTest = do
 
 getSessQueuesTest :: IO ()
 getSessQueuesTest = do
-  trq <- RQ.empty
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq
+  trq <- atomically RQ.empty
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
   checkDataInvariant trq `shouldReturn` True
-  atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4" "r4") trq
+  atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4") 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" "r1"]
-  atomically (RQ.hasSessQueues tSess1 trq) `shouldReturn` True
-  let tSess2 = (1, "smp://1234-w==@alpha", Just "c1")
-  RQ.getSessQueues tSess2 trq `shouldReturn` []
-  atomically (RQ.hasSessQueues tSess2 trq) `shouldReturn` False
-  let tSess3 = (0, "smp://1234-w==@alpha", Just "nope")
-  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" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"]
-  atomically (RQ.hasSessQueues tSess4 trq) `shouldReturn`True
+  atomically (RQ.getSessQueues (0, "smp://1234-w==@alpha", Just "c1") trq) `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1"]
+  atomically (RQ.getSessQueues (1, "smp://1234-w==@alpha", Just "c1") trq) `shouldReturn` []
+  atomically (RQ.getSessQueues (0, "smp://1234-w==@alpha", Just "nope") trq) `shouldReturn` []
+  atomically (RQ.getSessQueues (0, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"]
 
 getDelSessQueuesTest :: IO ()
 getDelSessQueuesTest = do
-  trq <- RQ.empty
+  trq <- atomically RQ.empty
   let qs =
-        [ ("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")
+        [ dummyRQ 0 "smp://1234-w==@alpha" "c1",
+          dummyRQ 0 "smp://1234-w==@alpha" "c2",
+          dummyRQ 0 "smp://1234-w==@beta" "c3",
+          dummyRQ 1 "smp://1234-w==@beta" "c4"
         ]
   atomically $ RQ.batchAddQueues trq qs
   checkDataInvariant trq `shouldReturn` True
   -- no user
-  atomically (RQ.getDelSessQueues (2, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([], [])
+  atomically (RQ.getDelSessQueues (2, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` ([], [])
   checkDataInvariant trq `shouldReturn` True
   -- wrong user
-  atomically (RQ.getDelSessQueues (1, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([], [])
+  atomically (RQ.getDelSessQueues (1, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` ([], [])
   checkDataInvariant trq `shouldReturn` True
   -- 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" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"], ["c1", "c2"])
+  atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"], ["c1", "c2"])
   checkDataInvariant trq `shouldReturn` True
   -- connections gone
   atomically (RQ.hasConn "c1" trq) `shouldReturn` False
@@ -153,31 +139,31 @@ getDelSessQueuesTest = do
 
 removeSubsTest :: IO ()
 removeSubsTest = do
-  aq <- RQ.empty
+  aq <- atomically RQ.empty
   let qs =
-        [ ("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")
+        [ dummyRQ 0 "smp://1234-w==@alpha" "c1",
+          dummyRQ 0 "smp://1234-w==@alpha" "c2",
+          dummyRQ 0 "smp://1234-w==@beta" "c3",
+          dummyRQ 1 "smp://1234-w==@beta" "c4"
         ]
   atomically $ RQ.batchAddQueues aq qs
 
-  pq <- RQ.empty
+  pq <- atomically RQ.empty
   atomically (totalSize aq pq) `shouldReturn` (4, 4)
 
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
+  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) aq >>= RQ.batchAddQueues pq . fst
   atomically (totalSize aq pq) `shouldReturn` (4, 4)
 
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "non-existent") "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
+  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "non-existent") aq >>= RQ.batchAddQueues pq . fst
   atomically (totalSize aq pq) `shouldReturn` (4, 4)
 
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@localhost", Nothing) "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
+  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@localhost", Nothing) aq >>= RQ.batchAddQueues pq . fst
   atomically (totalSize aq pq) `shouldReturn` (4, 4)
 
-  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "c3") "1" aq >>= RQ.batchAddQueues pq . map ("1",) . fst
+  atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "c3") aq >>= RQ.batchAddQueues pq . fst
   atomically (totalSize aq pq) `shouldReturn` (4, 4)
 
-totalSize :: RQ.TRcvQueues q -> RQ.TRcvQueues q -> STM (Int, Int)
+totalSize :: RQ.TRcvQueues -> RQ.TRcvQueues -> STM (Int, Int)
 totalSize a b = do
   qsizeA <- M.size <$> readTVar (RQ.getRcvQueues a)
   qsizeB <- M.size <$> readTVar (RQ.getRcvQueues b)
@@ -185,18 +171,18 @@ totalSize a b = do
   csizeB <- M.size <$> readTVar (RQ.getConnections b)
   pure (qsizeA + qsizeB, csizeA + csizeB)
 
-dummyRQ :: UserId -> SMPServer -> ConnId -> RecipientId -> RcvQueue
-dummyRQ userId server connId rcvId =
+dummyRQ :: UserId -> SMPServer -> ConnId -> RcvQueue
+dummyRQ userId server connId =
   RcvQueue
     { userId,
       connId,
       server,
-      rcvId,
+      rcvId = "",
       rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
       rcvDhSecret = "01234567890123456789012345678901",
       e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
       e2eDhSecret = Nothing,
-      sndId = NoEntity,
+      sndId = "",
       sndSecure = True,
       status = New,
       dbQueueId = DBQueueId 0,

tests/FileDescriptionTests.hs

@@ -13,7 +13,6 @@ 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
@@ -92,7 +91,7 @@ fileDesc =
     }
   where
     defaultChunkSize = FileSize $ mb 8
-    replicaId = ChunkReplicaId $ EntityId "abc"
+    replicaId = ChunkReplicaId "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, EntityId qId, Right cmd))] <- tGet h
+      [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
 ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation

tests/NtfServerTests.hs

@@ -17,7 +17,6 @@ import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.List.NonEmpty as L
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
 import SMPClient as SMP
@@ -36,6 +35,7 @@ import ServerTests
 import qualified Simplex.Messaging.Agent.Protocol as AP
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS
@@ -72,13 +72,13 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
 
 deriving instance Eq NtfResponse
 
-sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, 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, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, 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" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
+          RespNtf "1" "" (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", "", 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", NoEntity, SNEW $ NewNtfSub tId q nKey)
+          RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", "", SNEW $ NewNtfSub tId q nKey)
           -- send message
           threadDelay 50000
           Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello")
@@ -136,8 +136,8 @@ testNotificationSubscription (ATransport t) =
               Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
               Right message = ntfData' .-> "message"
               Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message
-              Right pnMsgs1 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
-              APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} = L.last pnMsgs1
+              Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} =
+                parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
               Right nMsgMeta = C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta
               Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta
           smpServer `shouldBe` srv
@@ -169,8 +169,8 @@ testNotificationSubscription (ATransport t) =
               Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce"
               Right message3 = ntfData3 .-> "message"
               Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3
-              Right pnMsgs2 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
-              APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2
+              Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} =
+                parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
           smpServer3 `shouldBe` srv
           notifierId3 `shouldBe` nId
           send3 APNSRespOk

tests/SMPAgentClient.hs

@@ -72,6 +72,8 @@ agentCfg =
       ntfCfg = defaultNTFClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig},
       reconnectInterval = fastRetryInterval,
       persistErrorInterval = 1,
+      ntfWorkerDelay = 100,
+      ntfSMPWorkerDelay = 100,
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt"

tests/SMPClient.hs

@@ -57,9 +57,6 @@ testStoreLogFile = "tests/tmp/smp-server-store.log"
 testStoreLogFile2 :: FilePath
 testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
 
-testDataLogFile :: FilePath
-testDataLogFile = "tests/tmp/smp-server-data.log"
-
 testStoreMsgsFile :: FilePath
 testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
 
@@ -107,7 +104,6 @@ cfg =
       queueIdBytes = 24,
       msgIdBytes = 24,
       storeLogFile = Nothing,
-      dataLogFile = Nothing,
       storeMsgsFile = Nothing,
       allowNewQueues = True,
       newQueueBasicAuth = Nothing,
@@ -119,7 +115,6 @@ 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",
@@ -163,7 +158,7 @@ withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasC
 withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, dataLogFile = Just testDataLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
+withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
 
 withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerConfigOn t cfg' port' =
@@ -223,7 +218,7 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
       [Right ()] <- tPut h [Right (sig, t')]
       pure ()
     tGet' h = do
-      [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
+      [(Nothing, _, (CorrId corrId, 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

@@ -19,9 +19,6 @@ import Control.Concurrent (ThreadId, threadDelay)
 import Control.Logger.Simple
 import Control.Monad (forM, forM_, forever, replicateM_)
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
-import Crypto.Hash (SHA512)
-import qualified Crypto.KDF.HKDF as H
-import qualified Data.ByteArray as BA
 import Data.ByteString.Char8 (ByteString)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
@@ -37,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 (DataBlob (..), EntityId (..), EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, e2eEncConfirmationLength, maxMessageLength, noMsgFlags)
+import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
 import Simplex.Messaging.Transport
@@ -136,25 +133,6 @@ smpProxyTests = do
       xdescribe "stress test 10k" $ do
         let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
         it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
-  describe "receive data blobs via SMP proxy" $ do
-    let srv1 = SMPServer testHost testPort testKeyHash
-        srv2 = SMPServer testHost testPort2 testKeyHash
-    describe "client API" $ do
-      describe "one server" $ do
-        it "deliver via proxy" . oneServer $ do
-          receiveBlobViaProxy srv1 srv1 C.SEd448 "hello"
-      describe "two servers" $ do
-        let proxyServ = srv1
-            relayServ = srv2
-        blob <- runIO $ atomically . C.randomBytes (e2eEncConfirmationLength - 2) =<< C.newRandom
-        it "deliver via proxy" . twoServersFirstProxy $
-          receiveBlobViaProxy proxyServ relayServ C.SEd448 "hello"
-        it "max blob size, Ed448 keys" . twoServersFirstProxy $
-          receiveBlobViaProxy proxyServ relayServ C.SEd448 blob
-        it "max blob size, Ed25519 keys" . twoServersFirstProxy $
-          receiveBlobViaProxy proxyServ relayServ C.SEd25519 blob
-        it "max blob size, X25519 keys" . twoServersFirstProxy $
-          receiveBlobViaProxy proxyServ relayServ C.SX25519 blob
   where
     oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const
     twoServers = twoServers_ proxyCfg proxyCfg
@@ -229,8 +207,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
   withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
     withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
       (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-      (aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-      liftIO $ sqSecured `shouldBe` True
+      aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
       liftIO $ pqSup' `shouldBe` PQSupportOn
       allowConnection alice bobId confId "alice's connInfo"
@@ -284,8 +261,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
     -- otherwise the CONF messages would get mixed with MSG
     prePair alice bob = do
       (bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-      (aliceId, sqSecured) <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-      liftIO $ sqSecured `shouldBe` True
+      aliceId <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       confId <-
         get alice >>= \case
           ("", _, A.CONF confId pqSup' _ "bob's connInfo") -> do
@@ -353,8 +329,7 @@ agentViaProxyRetryOffline = do
       withServer $ \_ -> do
         (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
           (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
-          (aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
-          liftIO $ sqSecured `shouldBe` True
+          aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
           ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
           liftIO $ pqSup' `shouldBe` PQSupportOn
           allowConnection alice bobId confId "alice's connInfo"
@@ -383,15 +358,11 @@ agentViaProxyRetryOffline = do
           -- proxy relay down
           4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2
           bob `down` aliceId
-        withServer2 $ \_ -> do
-          getInAnyOrder
-            bob
-            [ \case ("", "", AEvt SAENone (UP _ [c])) -> c == aliceId; _ -> False,
-              \case ("", c, AEvt SAEConn (A.SENT mId srv)) -> c == aliceId && mId == baseId + 4 && srv == bProxySrv; _ -> False
-            ]
-          runRight_ $ do
-            get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False
-            ackMessage alice bobId (baseId + 4) Nothing
+        withServer2 $ \_ -> runRight_ $ do
+          bob `up` aliceId
+          get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv)
+          get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False
+          ackMessage alice bobId (baseId + 4) Nothing
   where
     withServer :: (ThreadId -> IO a) -> IO a
     withServer = withServer_ testStoreLogFile testStoreMsgsFile testPort
@@ -426,65 +397,18 @@ agentViaProxyRetryNoSession = do
     withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2} testPort2
     servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]}
 
-receiveBlobViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> IO ()
-receiveBlobViaProxy proxyServ relayServ alg origData = do
-  g <- C.newRandom
-  -- proxy client
-  pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig Nothing (\_ -> pure ())
-  pc <- either (fail . show) pure pc'
-  THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-  -- relay client
-  rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig Nothing (\_ -> pure ())
-  rc <- either (fail . show) pure rc'
-  -- prepare blob
-  -- k: ID to retrive blob.
-  -- pk: part of the link sent to the accepting party (Sender role),
-  --     also key material for HKDF to derive key to e2e encrypt blob.
-  -- hash(k): ID used to store blob
-  -- (k, pk): used to agree additional server-to-client encryption when retrieving blob,
-  --          using DH with server session keys.
-  (C.PublicKeyX25519 k, pk'@(C.PrivateKeyX25519 pk _)) <- atomically $ C.generateKeyPair @'C.X25519 g
-  blobKeys@(_, blobPKey) <- atomically $ C.generateAuthKeyPair alg g
-  let kBytes = BA.convert k :: ByteString -- blob ID for "sender" (blob recipient)
-      rBlobId = EntityId $ C.sha256Hash kBytes
-      pkBytes = BA.convert pk :: ByteString
-      ikm = pkBytes
-      salt = "" :: ByteString
-      info = "SimpleXDataBlob" :: ByteString
-      prk = H.extract salt ikm :: H.PRK SHA512
-      skBytes = H.expand prk info 32
-  dataNonce <- atomically $ C.randomCbNonce g
-  Right sk <- pure $ C.sbKey skBytes
-  -- store blob
-  Right dataBody <- pure $ C.sbEncrypt sk dataNonce origData e2eEncConfirmationLength
-  let blob = DataBlob {dataNonce, dataBody}
-  runRight_ $ do
-    createSMPDataBlob rc blobKeys rBlobId blob
-    -- retrive blob directly
-    blob1@DataBlob {dataNonce = dataNonce1, dataBody = body1} <- getSMPDataBlob rc pk'
-    liftIO $ blob1 `shouldBe` blob
-    liftIO $ C.sbDecrypt sk dataNonce1 body1 `shouldBe` Right origData
-    -- retrive blob via proxy
-    sess <- connectSMPProxiedRelay pc relayServ (Just "correct")
-    Right blob2 <- proxyGetSMPDataBlob pc sess pk'
-    liftIO $ blob2 `shouldBe` blob
-    -- delete blob
-    deleteSMPDataBlob rc blobPKey rBlobId
-    liftIO $ runExceptT (getSMPDataBlob rc pk') `shouldReturn` Left (PCEProtocolError SMP.AUTH)
-    liftIO $ runExceptT (proxyGetSMPDataBlob pc sess pk') `shouldReturn` Left (PCEProtocolError SMP.AUTH)
-
 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", NoEntity, SMP.PRXY testSMPServer Nothing)
+      (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", 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", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong")
+      (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer2 $ Just "wrong")
       reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
   where
     proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"}

tests/ServerTests.hs

@@ -21,15 +21,11 @@ import Control.Concurrent.STM
 import Control.Exception (SomeException, try)
 import Control.Monad
 import Control.Monad.IO.Class
-import Crypto.Hash (SHA512)
-import qualified Crypto.KDF.HKDF as H
 import Data.Bifunctor (first)
-import qualified Data.ByteArray as BA
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Hashable (hash)
-import qualified Data.IntSet as IS
+import qualified Data.Set as S
 import Data.Type.Equality
 import GHC.Stack (withFrozenCallStack)
 import SMPClient
@@ -72,9 +68,6 @@ serverTests t@(ATransport t') = do
     testMsgExpireOnSend t'
     testMsgExpireOnInterval t'
     testMsgNOTExpireOnInterval t'
-  describe "Data blobs" $ do
-    testDataBlobs t'
-    testDataBlobsWithLog t
 
 pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg
 pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
@@ -85,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, EntityId, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
+sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, 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, EntityId, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
+signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, 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)
@@ -141,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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
-      (rId1, NoEntity) #== "creates queue"
+      (rId1, "") #== "creates queue"
 
       Resp "bcda" sId1 ok1 <- sendRecv s ("", "bcda", sId, _SEND "hello")
       (ok1, OK) #== "accepts unsigned SEND"
@@ -206,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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
-      (rId1, NoEntity) #== "creates queue"
+      (rId1, "") #== "creates queue"
 
       (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
       Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)
@@ -278,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 "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+        Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False)
         pure rId
       let subscribeQueues h = forM_ rIds $ \rId -> do
             Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
@@ -296,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" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+        Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
         pure ()
 
 testDuplex :: ATransport -> Spec
@@ -306,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", NoEntity, NEW arPub aDhPub Nothing SMSubscribe False)
+      Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False)
       let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
       -- aSnd ID is passed to Bob out-of-band
 
@@ -322,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", NoEntity, NEW brPub bDhPub Nothing SMSubscribe False)
+      Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", 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 (unEntityId bSnd))
+      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
       -- "reply_id ..." is ad-hoc, not a part of SMP protocol
 
       Resp "" _ (Msg mId2 msg2) <- tGet1 alice
       Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2)
       Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
-      (bId, encode (unEntityId bSnd)) #== "reply queue ID received from Bob"
+      (bId, encode 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)
@@ -361,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", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", 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"
@@ -498,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 NoEntity
+    recipientId1 <- newTVarIO ""
     recipientKey1 <- newTVarIO Nothing
     dhShared1 <- newTVarIO Nothing
-    senderId1 <- newTVarIO NoEntity
-    senderId2 <- newTVarIO NoEntity
-    notifierId <- newTVarIO NoEntity
+    senderId1 <- newTVarIO ""
+    senderId2 <- newTVarIO ""
+    notifierId <- newTVarIO ""
 
     withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
       (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
@@ -587,10 +580,10 @@ testRestoreMessages at@(ATransport t) =
 
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    recipientId <- newTVarIO NoEntity
+    recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
-    senderId <- newTVarIO NoEntity
+    senderId <- newTVarIO ""
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       runClient t $ \h1 -> do
@@ -617,7 +610,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 2
     logSize testStoreMsgsFile `shouldReturn` 5
-    logSize testServerStatsBackupFile `shouldReturn` 72
+    logSize testServerStatsBackupFile `shouldReturn` 55
     Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats1 [rId] 5 1
 
@@ -635,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` 72
+    logSize testServerStatsBackupFile `shouldReturn` 55
     Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats2 [rId] 5 3
 
@@ -654,7 +647,7 @@ testRestoreMessages at@(ATransport t) =
 
     logSize testStoreLogFile `shouldReturn` 1
     logSize testStoreMsgsFile `shouldReturn` 0
-    logSize testServerStatsBackupFile `shouldReturn` 72
+    logSize testServerStatsBackupFile `shouldReturn` 55
     Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
     checkStats stats3 [rId] 5 5
 
@@ -682,19 +675,19 @@ checkStats s qs sent received = do
   _msgSentNtf s `shouldBe` 0
   _msgRecvNtf s `shouldBe` 0
   let PeriodStatsData {_day, _week, _month} = _activeQueues s
-  IS.toList _day `shouldBe` map (hash . unEntityId) qs
-  IS.toList _week `shouldBe` map (hash . unEntityId) qs
-  IS.toList _month `shouldBe` map (hash . unEntityId) qs
+  S.toList _day `shouldBe` qs
+  S.toList _week `shouldBe` qs
+  S.toList _month `shouldBe` qs
 
 testRestoreExpireMessages :: ATransport -> Spec
 testRestoreExpireMessages at@(ATransport t) =
   it "should store messages on exit and restore on start" $ do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    recipientId <- newTVarIO NoEntity
+    recipientId <- newTVarIO ""
     recipientKey <- newTVarIO Nothing
     dhShared <- newTVarIO Nothing
-    senderId <- newTVarIO NoEntity
+    senderId <- newTVarIO ""
 
     withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
       runClient t $ \h1 -> do
@@ -749,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" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+  Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", 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"
@@ -778,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.25 -- normally the difference between "no queue" and "wrong key" is less than 5%
+    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- 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" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
+      Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
       let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
       Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
 
@@ -800,12 +793,12 @@ testTiming (ATransport t) =
 
       runTimingTest sh badKey sId $ _SEND "hello"
       where
-        runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> EntityId -> Command p -> IO ()
+        runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> ByteString -> 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", EntityId "1234", cmd)
+            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
             return ()
           threadDelay 100000
           timeWrongKey <- timeRepeat n $ do
@@ -813,7 +806,7 @@ testTiming (ATransport t) =
             return ()
           threadDelay 100000
           timeNoQueue <- timeRepeat n $ do
-            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd)
+            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
             return ()
           let ok = similarTime timeNoQueue timeWrongKey
           unless ok . putStrLn . unwords $
@@ -921,127 +914,6 @@ testMsgNOTExpireOnInterval t =
             Nothing -> return ()
             Just _ -> error "nothing else should be delivered"
 
-testDataBlobs :: forall c. Transport c => TProxy c -> Spec
-testDataBlobs t =
-  it "should store, retrieve, update and delete data blob directly from the server" $
-    smpTest2 t $ \r s -> do
-      g <- C.newRandom
-      -- k: ID to retrive blob.
-      -- pk: part of the link sent to the accepting party (Sender role),
-      --     also key material for HKDF to derive key to e2e encrypt blob.
-      -- hash(k): ID used to store blob
-      -- (k, pk): used to agree additional server-to-client encryption when retrieving blob,
-      --          using DH with server session keys.
-      (C.PublicKeyX25519 k, pk'@(C.PrivateKeyX25519 pk _)) <- atomically $ C.generateKeyPair @'C.X25519 g
-      (blobKey, blobPKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-      let kBytes = BA.convert k :: ByteString
-          rBlobId = EntityId $ C.sha256Hash kBytes
-          sBlobId = EntityId $ kBytes
-          pkBytes = BA.convert pk :: ByteString
-          ikm = pkBytes
-          salt = "" :: ByteString
-          info = "SimpleXDataBlob" :: ByteString
-          prk = H.extract salt ikm :: H.PRK SHA512
-          skBytes = H.expand prk info 32
-          origData = "hello"
-          origData2 = "hello 2"
-      dataNonce <- atomically $ C.randomCbNonce g
-      Right sk <- pure $ C.sbKey skBytes
-      -- store and retrieve blob
-      Right dataBody <- pure $ C.sbEncrypt sk dataNonce origData e2eEncConfirmationLength
-      let blob = DataBlob {dataNonce, dataBody}
-      -- storing data signed with the incorrect key fails (not matching key in command)
-      (_, blobPKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-      Resp "0" _ (ERR AUTH) <- signSendRecv r blobPKey' ("0", rBlobId, WRT blobKey blob)
-      -- correct key succeeds
-      Resp "1" _ OK <- signSendRecv r blobPKey ("1", rBlobId, WRT blobKey blob)
-      Resp "2" _ (DATA encBlob) <- sendRecv s ("", "2",  sBlobId, READ)
-      THandle {params = THandleParams {thAuth = Just THAuthClient {serverPeerPubKey}}} <- pure s
-      let ss = C.dh' serverPeerPubKey pk'
-          respNonce = C.cbNonce "2" -- correlation ID sent in READ request
-      Right blobStr <- pure $ C.cbDecrypt ss respNonce encBlob
-      Right  blob'@DataBlob {dataNonce = dataNonce', dataBody = body'} <- pure $ smpDecode blobStr
-      blob' `shouldBe` blob
-      Right origData' <- pure $ C.sbDecrypt sk dataNonce' body'
-      origData' `shouldBe` origData
-      -- update and retrieve blob
-      dataNonce2 <- atomically $ C.randomCbNonce g
-      Right dataBody2 <- pure $ C.sbEncrypt sk dataNonce2 origData2 e2eEncConfirmationLength
-      let blob2 = DataBlob {dataNonce = dataNonce2, dataBody = dataBody2}
-      -- storing data under the same ID but signed with the different key fails (even if it matches key in command)
-      (blobKey'', blobPKey'') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-      Resp "3" _ (ERR AUTH) <- signSendRecv r blobPKey'' ("3", rBlobId, WRT blobKey'' blob2)
-      -- same key but signed with the wrong key also fails
-      Resp "4" _ (ERR AUTH) <- signSendRecv r blobPKey'' ("4", rBlobId, WRT blobKey blob2)
-      -- same key bsucceeds
-      Resp "5" _ OK <- signSendRecv r blobPKey ("5", rBlobId, WRT blobKey blob2)
-      Resp "6" _ (DATA encBlob2) <- sendRecv s ("", "6",  sBlobId, READ)
-      let respNonce2 = C.cbNonce "6" -- correlation ID sent in READ request
-      Right blobStr2 <- pure $ C.cbDecrypt ss respNonce2 encBlob2
-      Right  blob2'@DataBlob {dataNonce = dataNonce2', dataBody = body2'} <- pure $ smpDecode blobStr2
-      blob2' `shouldBe` blob2
-      Right origData2' <- pure $ C.sbDecrypt sk dataNonce2' body2'
-      origData2' `shouldBe` origData2
-      -- remove data blob
-      -- incorrect ID fails
-      Resp "7" _ (ERR AUTH) <- signSendRecv r blobPKey ("7", sBlobId, CLR)
-      -- incorrect key fails
-      Resp "8" _ (ERR AUTH) <- signSendRecv r blobPKey'' ("8", rBlobId, CLR)
-      Resp "9" _ (DATA encBlob2') <- sendRecv s ("", "9",  sBlobId, READ)
-      encBlob2' `shouldBe` encBlob2'
-      -- correct key and ID succeed
-      Resp "10" _ OK <- signSendRecv r blobPKey ("10", rBlobId, CLR)
-      Resp "11" _ (ERR AUTH) <- sendRecv s ("", "11",  sBlobId, READ)
-      pure ()
-
-testDataBlobsWithLog :: ATransport -> Spec
-testDataBlobsWithLog at@(ATransport t) =
-  it "should store data blob to log and restore after server restart" $ do
-    g <- C.newRandom
-    (C.PublicKeyX25519 k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
-    (blobKey, blobPKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    dataNonce <- atomically $ C.randomCbNonce g
-    let kBytes = BA.convert k :: ByteString
-        rBlobId = EntityId $ C.sha256Hash kBytes
-        sBlobId = EntityId $ kBytes
-        blob = DataBlob {dataNonce, dataBody = "some random encrypted data"} -- the previous test shows e2e blob encryption
-        blob2 = DataBlob {dataNonce, dataBody = "some other encrypted data"}
-
-    clientServer t $ \h -> do
-      Resp "1" _ OK <- signSendRecv h blobPKey ("1", rBlobId, WRT blobKey blob)
-      pure ()
-    clientServer t $ \h -> do
-      testGetBlob h "2" pk sBlobId blob
-      -- update blob
-      Resp "3" _ OK <- signSendRecv h blobPKey ("3", rBlobId, WRT blobKey blob2)
-      testGetBlob h "4" pk sBlobId blob2
-    clientServer t $ \h -> do
-      -- updated after restart
-      testGetBlob h "5" pk sBlobId blob2
-      -- delete blob
-      Resp "6" _ OK <- signSendRecv h blobPKey ("6", rBlobId, CLR)
-      Resp "7" _ (ERR AUTH) <- sendRecv h ("", "7",  sBlobId, READ)
-      pure ()
-    clientServer t $ \h -> do
-      -- deleted after restart
-      Resp "8" _ (ERR AUTH) <- sendRecv h ("", "8",  sBlobId, READ)
-      pure ()
-  where
-    clientServer :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> IO ()
-    clientServer _ test' =
-      withSmpServerStoreLogOn at testPort $ \server -> do
-        testSMPClient test' `shouldReturn` ()
-        killThread server
-    testGetBlob h corrId pk sBlobId expectedBlob = do
-      Resp (CorrId corrId') _ (DATA encBlob) <- sendRecv h ("", corrId,  sBlobId, READ)
-      corrId' `shouldBe` corrId
-      THandle {params = THandleParams {thAuth = Just THAuthClient {serverPeerPubKey}}} <- pure h
-      let ss = C.dh' serverPeerPubKey pk
-          respNonce = C.cbNonce corrId -- correlation ID sent in READ request
-      Right blobStr <- pure $ C.cbDecrypt ss respNonce encBlob
-      Right  blob' <- pure $ smpDecode blobStr
-      blob' `shouldBe` expectedBlob
-
 samplePubKey :: C.APublicVerifyKey
 samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="
 

tests/XFTPServerTests.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module XFTPServerTests where
@@ -21,13 +20,13 @@ import Data.List (isInfixOf)
 import ServerTests (logSize)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description (kb)
-import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileInfo (..))
 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, EntityId (..), pattern NoEntity)
+import Simplex.Messaging.Protocol (BasicAuth, SenderId)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
@@ -75,8 +74,8 @@ createTestChunk fp = do
   B.writeFile fp bytes
   pure bytes
 
-readChunk :: XFTPFileId -> IO ByteString
-readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
+readChunk :: SenderId -> IO ByteString
+readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))
 
 testFileChunkDelivery :: Expectation
 testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
@@ -268,9 +267,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 NoEntity
-  rIdVar1 <- newTVarIO NoEntity
-  rIdVar2 <- newTVarIO NoEntity
+  sIdVar <- newTVarIO ""
+  rIdVar1 <- newTVarIO ""
+  rIdVar2 <- newTVarIO ""
 
   threadDelay 100000